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—  Returns  a  value 

function  SIN  (  ANGLE  :  in  RADIANS  )  return  FLOAT; 
ANGLE.SIN  :=  SIN  (  2  ); 
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procedure  may  only  be  updated.  Value 
may  change  after  completion. 
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—  local  declarations  go  here 
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RESULT  FIRST  -I-  SECOND; 
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PUT_LINE("I  hope  you  like  Ado") 
end  MEET.AND_GREET.Ada; 
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NEXT(MYJNTEGERJEMP); 

MYJNTEGER  :=  TEMP; 
end  loop; 

end  AELEXAMPLE; 
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TEMP  :=  MY  VALUE  *  YOUR_VALUE; 
—  Infix  notation 


Program  Units 


Structuring  tool 

Contains  a  visible  part  (  specification  ) 
and  a  hidden  part  (  private  part  and  body  ) 

Primary  means  for  extending  the  language 


Program  Units 


CD 

Cn 

D 

O 

o 

CL 


£  ri 

^  II 


CO  c 

z:  o 


O  c 

CD  9 


cj)  c; 


_s/  _ 

O  Q- 

o 

Q_ 


00 

O 

+ 

..  LU 
00  O 


^  II 
cm  :: 


cn  ° 


o  £L 

u  b 


-  O' 
“  < 
<D 


CM  O 


I 


end  CONSTANTS; 


ogram  Units 


Dh 


LlJ 

uj  5 
l l\  r< 


—  c 


co  cr 

<  < 

U-,  l±_ 

* * .  -  5  «• 

..Omoo 
o^ou 
o  :  :  ^ 

T~-  °  Q 

‘  ^  0  ry 

°  ?  a>£ 

el 

O  Cfl  CO  O 

—  —  Li-, 

co  LiJ  CO  o1 

—  p  LlJ  o 

OZUJu 

UJ  <  QJ  0 

u  c75  °  d 
a.  55  uj  -2 

0)00  0 

0  0  0  O 

Q.  CL  CL  P 

'  -4—'  CL 


UJ  5  LlJ 
UJ  LU 
CL-  ex 
CO  £  O 
r  Q  UJ 
•-  C  O 


co  cr  •• 
.<  .<  x 

0  0  2 

X  X  3 


m 

•  r-H 

£ 


c6 

Jh 

O 

C 

Oh 


oo^ 

h-  he  3 

3  ^  o 

80^ 

og§ 

mS-D 

o:*  S.E 


£  ® 
.—  cn 

£  D 


.«Q 

^q: 

0  $ 
CD  5 

WC£ 

^  o 


o  cno 

L.  CD 
CL  Xl 


•  “  £d 
'-'CZ  ■ 

o  < 

05  ^ 
s^cr 
— r  O 

X  ij_ 

C£  _l 
3  O 
h-  O 


•  -  o 
^cr 

0  $ 
o  5 


Ul—  _J 

3  O 

F-  o 


o  UJ 
O)  o: 


^  cn 

i-  ■o 


Program  Units 


Cl 

JC 

13 

co 

o  c 

r-  O 


CO  CO 
C  >- 
O  CO 

Jr-J  1  t 


r-  't' 

E  Q- 

0  c0 

Ql  C 

.i  "O 

G 

c  •- 


h-1  o  [j 

O  o  oo 

CD  -5  Ld 

O  £oc 

D-  TD  (D 

>>  —  b 

-O  O  ^ 
o  o  T3 

£  O  a> 
—  o 

CD  I  O 

cn  I  b 
O  1  CL 

V 


c  Ld 
CD  1— 


.£>  tn 
Q-h-1 

p  UJ 

.=  cn 

I  ^ 

DC 


procedure  GO_FORWARD...is. 
procedure  REVERSE. ..is... 
procedure  TURN. ..is... 

end  ROBOIXONTROL; 
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MY_MATRIX  (3,3)  :=  2.0; 
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MY_STRING(1 1..15)  :=  Y0UR_STRING(2 
MY_STRING(3..4)  :=  MY_STRING(4..5); 
MY_STRING(2)  :=  'G'; 
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function  NOW.SERVING  return  NUMBERS  is  separate; 
procedure  SERVE  (  NUMBER  :  in  NUMBERS  )  is 

separate; 
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type  NUMBERS  is  range  0..99; 
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VARIABLE  :=  70.0; 
end; 

VARIABLE  :=  10.0; 
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for  A_C0L0R  in  COLORS  loop 
PUT  ( AjCOLOR  ); 
NEWSLINE; 
end  loop; 
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end  EXAMPLE; 


•  m 


.  -  C 

0  t: 

4-»  CN 

O 

>  ^ 
LiJ 


Sh 

0 

£ 

O 


Ql 

co  n 

•-  ^ 
fcz  LU 

z:  h- 

bj  o 

2  CL 

LU  < 


LU  CO 


^  LU 
<  UJ 

s  -J 

CO  LU 


^  uj  rfj 

LUtL 

7  li  II 

II  •  •  •  * 


<D 

<D 

1 

0 

•  • 

CL 

0L 

1 

LJ 

o 

L- 

<D 

CL 

>N 

13 

“O 

CD 

L_ 

D 

■o 

CD 

ZS 

LU 

1 — 

C 

LU 

h- 

2 

LU 

1 — 

LU 

1— 

c 

O 

U 

’o> 

CD 

O 

L. 

O 

l. 

CD 

/*N 

CP 

Ql 

Q. 

JLj 

end  SWAP; 


Generics 


ZD 

if) 


•  *  co 

o  — 
1  tr 

i — '  Ld 

x  > 

UJ  7? 

«  ~z. 
3  < 


t“d  £ 

2  B-S 

z:  (—  a; 

£  £  q 

•  —  ♦  — •  L. 

£  BS  CL 


O 

Ld 

5  ch“ 

UJ  <! 
3  Q 


O  O 
51  ct 
o-  cr 

CO  Q 
—  ^ 

if)  O 

<:  h~- 
O  >- 

IB 


co  CC 
—  Ld 

O  f- 

— I  Ll. 
CO  < 

g£ 

Q  C 

v  c 
C  o 
o  *43 

-*  t; 

O  c 
S  3 

Q.  M— 


X  >- 
O  < 
“O  Q 

0  o 

_C  hj 


C  X 
Ld  O 

3  < 
Q_  Cl 


TOMORROW  :=  DA'CAFTER  (TODAY); 
PUT  (“Tomorrow  is:  "); 

DAYSJO.PUT  (TOMORROW); 
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GET  (INLELEMENT); 

PUSH  (INLELEMENT); 

POP  (INLELEMENT); 

PUT  ("The  element  popped  off  the  stack  was: 
PUT  (INLELEMENT); 
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end  SQUARING; 
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PUSH  (INT_ELEMENT); 

PUT  ("Enter  a  FLOAT  element  to  push  on  the  stack:  " 
GET  (FLOAT_ELEMENT); 

PUSH  (FLOAT_ELEMENT); 

end  STACK_0PS_2; 
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Tasking  may  be  implemented  on 

—  Single  Processors 

—  Multi— processors 

—  Multi— computers 
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null;  — tasks  are  started  here 
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and  are  communicating,  we  say  that  the 
two  tasks  are  in  "rendezvous" 
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—Used  to  unconditionally  terminate  a  task 
—Only  used  in  extreme  circumstances 

abort  CHANNEL; 
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end  LIST_PACKAGE; 


with  LISLPACKAGE,  TEXTJO; 
use  LISLPACKAGE.  TEXTJO; 


with  SWAP; 

package  body  L!ST_PACKAGE  is 

procedure  SWAPJTEMS  is  new  SWAP  (  ELEMENTJYPE  =>  ITEMS  ); 
procedure  SORT  (  ANXJ-IST  :  in  out  AJ-IST  )  is 
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end  LIST  PACKAGE; 


PUT_LINE("What  is  the  name  of  the  file  to  output  to?" 
GETJJNE(  FILENAME,  LAST  ); 
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begin 

PUTLLINE  ("This  program  sorts  a  list  of  names,  addresses  and 
PUTLLINE  (“phone  numbers  and  puts  that  sorted  list  in  a  file."] 
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GENERICS 


□  Why  program  at  all? 

□  Why  program  generically? 

□  What  does  generics  provide? 

□  How  do  you  write  a  generic  unit? 

□  Parameterless  Generics 

□  Parameterized  Generics 

□  Value  and  Object  Parameters 

□  Type  Parameters 

□  Subprogram  Parameters 

□  What  are  the  Cons  of  generics? 

□  What  are  the  Pros  of  generics? 

□  What  are  the  unresolved  issues? 


□  How  do  you  teach  generics? 


Why  program  at  all? 


□  Reusability  -  a  programmed  solution 
can  be  used  over  and  over 

□  Reliability  -  program  can  be  tested  and 
verified  to  ensure  correct  results  for 
subsequent  runs 

□  Readability  -  program  formalizes  human 
solution  and  represents  it  in  more 
abstract  readable  form 

□  Maintainability  -  making  a  change  to 
a  program  ensures  that  the  change  is 
consistently  applied  to  all  problem 
solutions 


Why  program  genericaliy? 


□  Reusability  -  similar  program  units 
needed  but  different  enough  to 
preclude  simply  entering  differing 
values  at  run  time 

□  Reliability  -  generic  unit  once  tested 
and  verified  does  not  need  to  be  retested 
for  each  new  use  or  "instantiation" 

□  Readability  -  using  generic  unit  allows 
extraction  of  the  "essence"  of  the  unit 
eliminating  application  specific  details 
and  produces  a  very  uncluttered  readable 
unit 

□  Maintainability  -  a  change  made  to  the 
unit  applies  to  all  uses  of  the  unit 

□  Programming  in  the  large  -  facilitates 
concentration  on  higher  layers  of 
abstraction  by  providing  reusable 
conceptual  building  blocks 
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What  does  generics  provide? 


•  Templates  for  conceptual  building 
blocks 

•  Remove  problem  specifics  =>  greater 
clarity  and  understandability  of 
code 

•  Can  add  levels  of  abstraction 

•  Reduces  source  code  size  =>  code 
more  readable  and  maintainable 

•  Facilitates  REUSE  of  software 

•  Elegant  complement  to  strong  typing 


•  Mechanism  for  doing  I/O 
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Generic  Stack  Packages 


records 


Creating  a  "Need"  for  Generics 
-  A  Simple  Example  - 


□  Long  Integers  Problem 

□  Problem  is  to  be  able  to  add  and 
multiply  non-negative  integers  of 
unlimited  digits 

□  Simple  problem  to  understand 

□  Creates  "cognitive  dissonance"  and 
"need"  in  student  to  solve  problem 

□  Need  for  generic  unbounded  stack 
is  relatively  obvious 

□  Illustrates  layers  of  abstraction 

□  Long  Integer  -  Top  Level 

□  Original  level  of  student  focus 

□  Stack  -  Bottom  Level 

□  Second  level  of  student  focus 


Conceptual  Building  Blocks 
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Long  Integers  Problem 

An  Example: 


with  Long_Integer_Stack; 
package  Long_Integers  is 

type  Long_Integer  is  private; 

function  Make_Long_Integer (Numeral  :  in  string)  return  Long_Integer ; 

function  (First_Long_Integer,  Second_Long_Integer  :  Long_Integer) 

return  Long_Integer ; 

function  "*"(N  :  Natural;  A_Long_Integer  :  Long_Integer) 
return  Long_Integer ; 

function  (First_Long_Integer ,  Second_Long_Integer  :  Long_Integer) 

return  Long_Integer ; 

procedure  Put (A_Long_Integer  :  in  Long_Integer)  ? 
private 

type  Long_Integer  is  new  Long_Integer_S tack. Stack; 
end  Long_Integers ; 


rh  Text_IO; 

ckage  body  Long_Integers  is 
use  Long_Integer_Stack; 

function  Make_Long_Integer (Numeral  :  in  string)  return  Long_Integer 
L  :  Long_Integer ; 
begin 

Clear (L) ; 

for  Position  in  Numeral ' first . .Numeral ' last  loop 

Push ( character 'pos (Numeral (Position) ) -character ' pos (’O') , L) ; 
end  loop; 
return  L; 

end  Make_Long_Integer ; 

function  ”+” (First_Long_Integer ,  Second_Long_Integer  :  Long_Integer) 
return  Long_Integer  is 
ReversedSum,  Sum  ;  Long_Integer ; 

Carry  :  integer  :=  0; 

SingleColumnSum  :  integer  :=  0; 

LI  :  Long_Integer  :=  First_Long_Integer ; 

L2  :  Long_Integer  :=  Second_Long_Integer ; 
begin 


Clear (ReversedSum) ; 
Clear (Sum) ; 


while  (NOT  Is_Empty (LI) )  and  (NOT  Is_Empty (L2 ) )  loop 
SingleColumnSum  :=  Top_0f(Ll)  +  Top_0f(L2)  +  Carry; 

Push (SingleColumnSum  mod  10 , ReversedSum) ; 

Carry  ;=  (SingleColumnSum  -  (SingleColumnSum  mod  10))  /  10; 
Pop (Ll) ; 

Pop (L2 ) ; 
end  loop; 

while  NOT  Is_Empty(Ll)  loop 

SingleColumnSum  :=  Top_0f(Ll)  +  Carry; 

Push (SingleColumnSum  mod  10 , ReversedSum) ; 

Carry  :=  (SingleColumnSum  -  (SingleColumnSum  mod  10))  /  10; 
Pop (Ll) ; 
end  loop; 


while  NOT  Is_Empty(L2)  loop 

SingleColumnSum  :=  Top_Cf(L2)  -  Carry; 

Push (SingleColumnSum  mod  10 , ReversedSum) ; 

Carry  :=  (SingleColumnSum  -  (SingleColumnSum  mod  10))  /  10; 
Pop (L2 ) ; 
end  loop; 


if  Carry  =  1  then 

Push (1, ReversedSum) ; 
end  if; 


while  NOT  Is_Empty (ReversedSum)  loop 
Push (Top_Of (ReversedSum) ,Sum) ; 

Pop (ReversedSum) ; 
end  loop; 

return  Sum; 
end  "+"; 


for  Count  in  1..N  loop 

Result  :  =  Result  +  A_Long_Integer ; 
end  loop; 
return  Result; 
end  " * " ; 

function  (First_Long_Integer ,  Second_Long_Integer  ;  Long_Integer) 
return  Long_Integer  is 

LI  :  Long_Integer  ;=  First_Long_Integer ; 

L2  ;  Long_Integer  :=  Second_Long_Integer ; 

Result  :  Long_Integer  :=  Make_Long_Integer ("O'* )  ; 

Digit  ;  integer; 

Position  :  integer  ;=  0; 

Temp  :  Long_Integer ; 
begin 

while  NOT  Is_Empty(Ll)  loop 
Digit  :=  Top_Of(Ll); 

Pop (LI) ; 

Position  ;=  Position  +1; 

Temp  :=  Digit  *  L2 ; 

for  NumberOfTrailingZeros  in  2.. Position  loop 
Push (0, Temp) ; 
end  loop; 

Result  :=  Result  +  Temp; 
end  loop; 
return  Result; 
end  " * "  ; 

procedure  Put (A_Long_Integer  :  in  Long_Integer)  is 
Temp,  Temp 2  :  Long_Integer ; 
begin 

Temp  :=  A_Long_Integer ; 

—  reverse  contents  of  Temp  into  Temp 2 
while  NOT  Is_Empty (Temp)  loop 

Push (Top_Of (Temp) , Temp2 ) ; 

Pop (Temp) ; 
end  loop; 

—  print  contents  of  Temp2  on  screen 
while  NOT  Is_Empty (Temp 2 )  loop 

Text_IG . Put ( integer ’ image (Top_0f (Temp2 } ) (2) ) ; 

Pop (Temp 2 ) ; 
end  loop; 
end  Put; 


nd  Long  Integers ; 


zh  Long_Integers ,  Text_IO;  use  Long_Integers ,  Text__IO; 
acedure  Uselongintegers  is 
A,  B  :  Long_Integer ; 

}in 

A  :=  Make_Long_Integer ("25012345") ; 

B  :=  Make_Long_Integer ("22334455") ; 

Put  (A  *  B)  ; 

New_Line; 

Put (2*A) ; 

3  UseLonglntegers ? 


generic 

type  Item  is  private; 

package  Stack_Sequential_Unbounded_Unmanaged_Noniterator  is 


type  Stack  is  limited  private; 


procedure  Copy  (From_The_Stack 

To_The_Stack 

procedure  Clear  (The_Stack 
procedure  Push  (The_Item 

On_The_Stack 

procedure  Pop  (The_Stack 

function  Is_Equal  (Left  : 

Right  : 

function  Depth_Of  (The_Stack  : 
function  Is_Empty  (The_Stack  : 
function  Top_Of  (The_Stack  : 


• 

• 

in 

Stack; 

• 

in  out 

Stack) 

• 

t 

• 

in  out 

Stack) 

7 

• 

• 

in 

Item ; 

in  out 

Stack) 

7 

in  out 

Stack) 

7 

in 

Stack; 

in 

Stack) 

return 

Boolean; 

in 

Stack) 

return 

Natural ; 

in 

Stack) 

return 

Boolean; 

in 

Stack) 

return 

Item; 

Overflow  :  exception; 
Underflow  :  exception; 


private 

type  Node ; 

type  Stack  is  access  Node; 

end  Stack_Sequential_Unbounded_Unmanaged_Noniterator ; 


[Taken  from  Software  Components  with  Ada  by  Grady  Booch] 


th  Stack_Sequential_Unbounded_Uninanaged_Noniterator ; 
ckage  Long_Integer_Stack  is  new 

Stack_Sequential_Unbounded_Unmanaged_Noniterator( I tem=> integer)  ; 


Traditional  Programming 


Algorithms,  Objects,  Resources 
—  intermixed  with  — 
Problem  specifics 


procedure  Swap(X,Y  :  in  out  integer)  is 
Temp  :  integer  X; 

begin 
X  :=  Y; 

Y  :=  Temp; 
end; 

procedure  Swap(X,Y  :  in  out  character)  is 
Temp  :  character  :=  X; 

begin 
X  :=  Y; 

Y  :=  Temp; 
end; 

procedure  Swap(X,Y  :  in  out  float)  is 

Temp  :  float  :=  X; 

begin 
X  :=  Y; 

Y  :=  Temp; 
end; 


type  AnArray  is  array (i..  10)  of  integer; 

procedure  Swap(X,Y  :  in  out  AnArray)  is 
Temp  :  AnArray  :=  X; 
begin 
X  :=  Y; 

Y  :=  Temp; 
end; 


Generic  Programming 

Algorithms,  Objects,  Resources 
separated  from 


Syntax  and  Semantics 


generic 

.  .  .  generic  formal  parameters  .  .  . 
subprogram  or  package  specification; 


subprogram  or  package  body 


A  Generic  Swap  Procedure 


generic 

type  Element  is  private; 
procedure  Swap(X,Y :  in  out  Element); 

procedure  Swap(X,Y :  in  out  Element)  is 
Temp ;  constant  Element  :=  X; 
begin 
X:=  Y; 

Y  ;=  Temp; 
end  Swap; 


NO!!  Generic  units  not  "caliable/usable 


I  l 


Explicit 

Instantiation 

•  Creates  callable/ usable  unit 


with  Swap; 
procedure  Example  is 
»  •  • 

procedure  Char  Swap  is  new  Swap  (character): 
procedure  IntSwap  is  new  Swap(Element=>integer); 

begin 

CharS  wap(OneLetter,AnotherLetter); 
IntSwap(AnInteger,  Anotherlnteger) ; 

end  Example; 


Overloading  Instance  Names 


with  Swap; 

procedure  Swap  Things  is 
X  :  integer  5; 

Y  :  integer  10; 

A  :  character  :=  A'; 

B  :  character  :=  *B‘; 

procedure  Exchange  is  new  Swap  (character) 
procedure  Exchange  is  new  Swap(integer); 

begin 

Exchanged, Y); 

Exchange(A,B); 

end; 


Data  Object: 


Generic  Unit: 


Generic  Units 
An  Analogy 


Declaration 

Type  Declaration 

type  Age  is  range  0..  100; 
Generic  Declaration 
generic 

type  Element  is  private; 
procedure  DoSometJmg; 

procedure  DoSomething  is 
X:  Element; 
begin 

. .  do  something . . . 
end DoSometJiing; 


Instantiation 

Object  Declaration 

Old  Age :  Age ; 

Generic  Instantiation 

procedure  Eoflv's  is 
newIbSemetding 
{Element --■'integer/. 


Explicit 


nstantiat ion 


generic 

type  Element  is  <>; 

procedure  Swap  (X,Y  :  in  out  Element); 
procedure  Swap  (X,Y  :  in  out  Element)  is 
Temp  :  Element  :=  X; 
begin 
X  :=  Y; 

Y  :=  Temp; 
end; 


with  Swap; 

procedure  SwapThings  is 
X  :  integer  :=  5; 

Y  ;  integer  ;=  10; 

A  :  character  :=  'A'; 

B  :  character  -  '8'; 
begin 

Swap(X,Y);  —  Why  NOT? 

Swap(A,B);  --  param  types  differ  after  all 
end  SwapThings; 


□  Requirement  to  EXPLICITLY  instantiate 
simplifies  compilation  of  units 


□  l  he  explicit  instantiation  provides 
well-defined  locus  for  reporting  errors 

3  ^  i  c  ■  r>  ,-i  f  ^ I'.'  r,  c  l  c  '  o  r,  j-  ci  j  r,  c  f  i  f  i  i  f  ■  ■'i  r,  c 


Explicit  instantiation  (continued. 


□  Permits  independent  checkino  of  aeneri 

'  v/ 

units  and  aeneric  instantiations 


c 


□  Resolves  ambiguity  of  reference  that 
might  otherwise  occur 

□  Provides  better  awareness  of  instances 
and  improves  reliability  and  readability 


with  Swap; 

procedure  SwapThings  is 
X  :  integer  :=  5; 

Y  :  integs^  :=  10; 

A  :  character  :=  'A'; 
d  :  character  :=  B'; 


procedure  Swap(X,v 
beain 
X  :=  1 ; 

Y  :=  1; 
end  Swap; 


or 


beain 

Swap(X,Y);  --  generic  Swap  used 
Swap(A,B),  --  local  Swap  masks  generic  one 
end  SwapThings; 


l—  *;  v  i  « i-4 


Parameleriess  Generics 
"Cloning"  Units 


A  nongeneric  "unique  object"  Stack  package: 

package  Stack  is 
procedure  Pop(I  :  out  integer); 
procedure  Push(I  :  in  integer); 
function  Empty  return  boolean; 
function  Full  return  boolean; 
end  Stack; 

A  non-generic  "many  objects"  solution: 

package  Stacks  is 
type  Stack  is  .  .  .; 

procedure  PoptS  :  in  out  Stack;  I  :  out  integer); 
procedure  Push(S  :  in  out  Stack;  I  :  in  integer): 
function  Ernpty(S  :  Stack)  return  boolean; 
function  Full(S  :  Stack)  return  boolean; 
end  Stacks; 

—  changes  must  be  made  to  body  of  package  also 

A  sample  user  program: 
procedure  Stack  Up  is 
SI,  S2  :  Stack;  Item  :  integer; 
begin 

Push(Sl,10);  Push(S2.5);  Pop(SlJtem); 

pnn  ■ 
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Parameterless  Generics  cont. 


A  generic  "many  objects"  solution: 
generic 

package  Stack  is 
procedure  Pop  (I  :  out  integer); 
procedure  Push(I  :  in  integer); 
function  Empty  return  boolean: 
function  Full  return  boolean; 
end  Stack; 

—  generic  body  is  identical  to  non-generic  one 

—  no  changes  have  to  be  made  to  get  many  stacks 

A  sample  user  program: 

with  Stack; 
procedure  StackUp  is 
Item  :  integer; 
package  SI  is  new  Stack; 
oackase  S2  is  new  Stack; 
begin 

Sl.Push(lO);  S2.Push(5); 

SI .Pop(Item);  S2. Pop  (Item); 
end  StackUp; 


Parameterless  Generics  cont. 


□  Stack  implementations  compared 

□  Non-generic  package  -  only  one 
elaboration  and  initialization  occur 

□  Generic  package  -  multiple 
elaborations  and  initializations  occur 
-  once  for  each  package 


Example:  withTexUO; 

package  body  Stack  is 
■  •  * 

begin 

Text_IO.Put("New  stack  created."); 
end  Stack; 


package  SI  is  new  Stack;  --  message  prints 
package  S2  is  new  Stack,  —  message  prints  again 
pacakge  S3  is  new  Stack;  —  message  prints  again 


Creating  Library  Units 

of 

Generic  Instantiations 


—  compile  following  separately  into  the  library 
with  Stack; 

package  SI  is  new  Stack; 


—  SI  is  now  a  usable  library  unit 

with  SI;  use  SI; 
procedure  StackUp  is 
Item  :  integer; 
begin 
Push(lO); 

Push(20); 

Pop(Item); 
end  StackUp; 


Parameterized  Generics 


□  Generic  Parameters 

□  Value  and  Object  Parameters 

□  Type  Parameters 


□  Subprogram  Parameters 


Value  and  Object  Parameters 


□  Value  Parameters 

□  Are  of  mode  IN 

□  Serve  as  local  constants  in 
generic  units 


□  Object  Parameters 

□  Are  of  mode  IN  OUT 

□  Serve  as  global  objects  in 
generic  units 


Value  Parameters 


generic 

Max  :  in  integer; 

Min  :  integer;  —  default  mode  is  IN 
procedure  BigNSmall(X  :  in  integer); 

procedure  BigNSmall(X  :  in  integer)  is 
begin 

if  X  >  Max  then 

Max  :=  X;  —  not  with  mode  IN 
end  if; 

if  X  <  Min  then 

Min  :=  X;  —  not  with  mode  IN 
end  if; 

end  BigNSmall; 


Value  Parameters 
and 

Initialization  Before  Instantiation 


□  Actual  parameters  which  are  to  match 
with  formal  generic  value  parameters 
"must"  have  been  initialized  before  the 
instantiation  occurs 

Example: 

generic 

Max  :  in  integer; 

Min  :  integer;  —  default  mode  is  IN 
procedure  BigNSmall(X  :  in  integer); 

with  BigNSmall; 
procedure  UseBigNSmall  is 
LocalMin  :  integer;  --no  initial  value 
LocalMax  :  integer;  —  no  initial  value 
X  :  integer  >100; 

procedure  Extremes  is  new 

BigNSmall  (Max=>LocalMax,Min=>LocalMin); 

—  run-timeerror  occurs  due  to  lack  cf  initialization  IF  contents 

—  of  uninitialized  objects  raises  constraint_errcr 

begin 

Extremes  (X); 
end  UseBigNSmall; 


Value  Parameters 
and 

Levels  of  Abstraction 


generic 

Lower,  Upper  :  in  character; 
function  In_Range(S  :  in  string)  return  boolean; 

function  In_Range(S  :  in  string)  return  boolean 
begin 

for  I  in  S'Range  loop 
if  S(I)  not  in  Lower. .Upper  then 
return  FALSE; 
end  if; 
end  loop; 
return  TRUE; 
end  In_Range; 

A  non-generic  version  of  In_Range: 

function  InJRange(S  :  in  string;  Upper, Lower  : 

character)  return  boolean  is 
begin 

for  I  in  S'Range  loop 
if  S(I)  not  in  Lower  ..  Upper  then 
return  FALSE; 
end  if; 
end  loop; 
return  TRUE; 
end  InJRange; 


Value  Parameters 
and 

Levels  of  Abstraction  cont. 


□Compare  clarity  in  user’s  programs  using 
generics  to  add  another  level  of  abstraction 
in  "customized  “  names  for  In_Range  function 

with  In_Range; 
procedure  InBounds  is 
Name  :  string(  1  A)  :=  “JACK"; 

Phone  :  string!  1 77)  :=  “6725643"; 
begin 

if  InJtenge(Name/A7Z')  then  . . . 
if  In_Range(Phone/079’ )  then  . . . 
end  InBounds; 


with  In_Range; 
procedure  InBounds  is 
Name  :  string!  I  A)  :=  “JACK"; 

Phone  : string!  1 7)  :=  "6725642’'; 

function  Is_All_Upper_Case  is  new  In_Range('A7Z'); 

function  Is_AU_Lower_Case  is  new  In_Range('a7z'); 

function  Is-AlLDecimal  is  new  ln-Range('079'); 

begin 

if  Is_Ail_UpperJ2ase(Name)  then  . . . 
if  Is_AlLDecimal!Phone)  then  . . . 
end  InBounds; 


[*In_Range  taken  from  Ada  Language  and  Methodology] 


Value  Parameters 


Our  Stack  Example  Revisited 

generic 

Si2e  :  in  natural; 
package  Stacks  is 
type  Stack  is  limited  private; 
procedure  Push(S  :  in  out  Stack;  I  :  in  integer); 
procedure  Pop(S  :  in  out  Stack;  I  :  out  integer); 
private 

subtype  NumberOfElements  is  integer 
range  O..Si2e; 
type  ElementArray  is 
array(NumberOfElements)  of  integer; 
type  Stack  is  record 
Elements  :  Element_Array; 

Top  :  NumberOfElements  :=  0; 
end  record; 
end  Stacks; 

with  Stacks; 
procedure  StackUp  is 
package  SmallStack  is  new  Stacks(5); 
pacakge  BigStack  is  new  Stack(5000); 
begin 


Value  Parameters 
and 

Default  Values 

(only  on  VALUE  parameters,  not  OBJECT  parameters) 

generic 

Rows  :  in  positive  :«  24; 

Columns  :  in  positive  80; 
package  Terminal  is 
•  •  • 

end  Terminal; 

—  some  possible  instantiations 

package  MicroTerminal  is  new  Terminal(24,4Q); 

—  using  positional  notation 

package  WordProcessor  is  new 

Terminal(Columns=>S5,Rows=>66); 

—  using  named  notation 

package  DefaultTerminal  is  new  Terminal; 

—  using  the  default  values  of  24  and  80 

package  NewTerminal  is  new 
Terminal(X+Y,Z+  10); 

—  using  expressions 


Value  Parameters 
and 

The  Subtleties  of  Default  Values 


What  are  the  outputs  of  the  following? 

package  CountingPackage  is 
function  NestWum  return  integer; 

generic 

Vai :  integer  :=  NeztNum; 
procedure  Count; 
end  CountingPackage; 

with  Text  JO; 

package  body  CountingPackage  is 
CurrentValue  ;  integer  :=  0; 
function  NextNum  return  integer  is 
begin 

CurrentValue  -  CurrentValue  +  1 , 
return  CurrentValue; 
end  NextNirn, 


begin 

T  ext  J  0  .PulJune  ( integer 1 1  image  ( ' Val ) ) ; 
end  Count, 

end  CountingPackage, 

with  CountingPackage; 
procedure  StartCounting  is 
procedure  FirsiCount  is  new  CountingPackage. Count; 
procedure  Count  Again  is  new  CountingPackage. Count; 
begin 

FirstCount; 

Count  Again, 
er.d  CtartCounun?' 


AN  IMPLEMENTATION  DEPENDENCY 


with  Text_IO;  use  Text_IO; 
procedure  Imp  is 


Counter  :  integer  :=  0; 


generic 

A  :  in  integer; 
B  ;  in  integer; 
procedure  X; 


procedure  X  is 
begin 

put_line ( integer ' image (A+B) ) ; 
end  X; 


function  Next  return  integer  is 
begin 

Counter  :=  Counter  +  1; 
return  Counter; 
end  Next; 


procedure  InstanceOfX  is  new  X 


of 


begin 

InstanceOfX; 
end  Imp ; 


Value  Parameters 
and 

Limited  Types 


□  Value  parameters  are  constants  whose 
value  is  a  copy  of  the  value  of  the 
generic  actual  parameter  supplied 

in  the  instantiation. 

□  Type  of  generic  formal  value  parameter 
therefore  cannot  be  limited  type  because 
copy  of  actual  parameter  value  cannot  be 
assigned  to  it. 

with  Text_IO; 
generic 

MyFile  :  Text_IO.File_Type;  --  NO! 
procedure  Wrong; 

—  problem  is  File_Type  is  limited  private 


Object  Parameters 
A  More  Useful  Example 


generic 

Control-Block  :  in  out  DeviceData; 

Kind  :  in  VDU_Kind  Basic-Kind; 
package  VDU  is 
•  •  0 

end  VDU; 
with  VDU; 

procedure  ManyVDUs  is 
DeviceTable  :  array!  1..N)  of  DeviceData; 

package  VDU  1  is  new 

VDU(DeviceTable(l  ),Kind_A); 
package  VDU2  is  new 

VDU(DeviceTable(2),Kind_B); 

begin 
•  •  • 

end  ManyVDUs; 


[Taken  from  Ada  Language  and  Methodology  by  watt,  wichmann,  and  Findlay] 


Object  Parameters 
and 

Subtleties 

□  Object  parameters  passed  by  reference 
not  by  copy-restore  method 

□  Object  parameters  are  "aliases"  for  their 
actual  parameter  counterparts 

Example: 

with  Text_IO;  use  Text_I0; 

procedure  X  is 
Global :  integer  :*=  99; 
procedure  Z(Param  :  in  out  integer)  is 
begin 

Par  am  :=  Par  am  +  1 ; 

Pu:JLine(integer'image(Param)); 

PuL_Line(integer’image(Global)); 
end  Z; 

begin 

Z(Global); 

end  X; 

—  output  is  100,  99  for  copy-restore  method 

—  output  is  1 00, 1 00  for  pass  by  reference 


Object  Parameters 
and 

Subtleties  cont. 

□  Object  parameters  passed  by  reference 
not  by  name  —  not  like  Algol  s  "copy 
rule" 

□  Address  of  actual  parameter  corresponding 
to  formal  generic  object  parameter  is 
evaluated  ONCE  and  does  not  change 

□  Using  generic  object  parameter  NOT  like 
doing  textual  substitution  of  actual 
parameter' s  name 


Object  Parameters 
and 

Subtleties  coni. 


ADDRESS  of  actual  parameter 
corresponding  to  a  generic  formal  object 
parameter  is  evaluated  at  time  of 
instantiation 


declare 

Y  :  array(  1.. 5)  of  character  :=  "kitty"; 

TnHov  •  interror  •=  1- 

A  AX  V*  \S  A  A  •  AAAWWfjWA  • 


generic 

X  :  in  out  character; 
procedure  Replace; 


procedure  Replace  is 

ban  i  n 

i  ii 

irsrlpv  •=  n  • 

A  AAV*  Vi\  •  , 

X  :=  w  ;  -X 

Put(String(Y)); 
end  Replace; 


Y(l),  NOT  Y(5) 


procedure  Update  is  new  Replace(Y(Index)) 
--  Index  =  1  when  this  instantiation  occurs 


begin 

Update; 

end; 


NON-EXAMPLE 


declare 

Y  :  array (1.. 5)  of  character  :=  "kitty"; 

Index  :  integer  :=  1 ; 

generic 

X  :  in  out  character; 
procedure  Replace; 

procedure  Replace  is 
begin 
Index  :=  5; 

Put(String(Y)); 
end  Replace; 

procedure  Update  is  new  Repiace(WlEsiifi©S$) 
—  Index  =  i  when  this  instantiation  occurs 

begin 

Update; 

end; 


declare 

subtype  Small  is  integer  range  1  ..  10; 

X  :  integer  :»  27; 
generic 
S  :  fiai  Small; 
procedure  Gen; 
procedure  Gen  is 
begin 

Putl'All  OKM); 
end  Gen; 

procedure  P  is  new  Gen(X); 

—  Constraint_Error  raised  at  time  of  instant, 
begin 
P; 
end; 


declare 

subtype  Small  is  integer  range  1 ..  1 0 

X  :  integer  :=  27; 

generic 

S  :  to  Small; 
procedure  Gen; 
procedure  Gen  is 
begin 

PutC'All  OK"); 
end  Gen; 

procedure  P  is  new  Gen(X); 

—  executes  OK  — 
begin 
P; 

end; 


Object  Parameters 
and 

Constraints  Imposed 


□  Constraints  applied  to  generic  formal 
object  parameter  are  those  of  corresp. 
ACTUAL  parameter. 


declare 

subtype  Small  is  integer  range  1..1Q; 
X  :  a&SStPF  :=  10; 


generic 

S  :  ft®  Small; 
procedure  Constraints; 
procedure  Constraints  is 
begin 
S  :=  S  +  1 ; 
end; 


procedure  Actual  Constraint  is  new 
Constraints(X);  --  causes  NC  problem 

—  constraints  of  a&SSfps*  apply 

begin 

Actual  Constraint; 


declare 

subtype  Small  is  integer  range  1..10: 
X  :  §ans22  10; 


generic 

S  :  Slfi  Small; 
procedure  Constraints; 
proc  ed  i  jre  Constraints  is 
begin 
S  •=  S  +  1- 
end; 

procedure  Actual  Constraint  is  new 
Constraints(X);  —  causes  problem 

—  constrains  of  SsMIl  apply 

begin 

Actual  Constraint; 
end; 


Object  Parameters 


□  Use  not  recommended  because  suffer 
from  all  same  falacies  as  global  objects 

□  Generic  object  parameters  usually 
SHOULD  have  been  regular  formal 
parameters  in  the  subprogram 


Object  Parameters  cont. 


generic 

Variable  :  in  out  integer; 

Limit,  ResetValue  :  in  integer; 
procedure  ResetlntegerTemplate; 

procedure  ResetlntegerTemplate  is 
begin 

if  Variable  >  Limit  then 
Variable  :=  ResetValue; 
end  if; 

end  ResetlntegerTemplate; 


Better  written  as  .  .  . 
generic 

Limit,  ResetValue  :  in  integer; 
procedure  ResetlntegerTemplatei'Variable  :  in  out 
integer;; 


procedure  ResetIntegerTemplate(Variable  :  in  cut 
integer)  is 
begin 

if  Variable  >  Limit  then 
Variable  :=  ResetValue; 
end  if; 

end  ResetlntegerTemplate; 


{  A  * 


f  ^AfVV 
11  WAW 


Ada  As  a  Second  Language  by  Cohen] 


Object  Parameters 
and 

Defined  Operations 


□  Operations  defined  on  object  are  the 
basic  or  predefined  operators  defined 
for  the  matching  actual  type.  . .  even 
if  operator  redefined  for  actual  type  or 
parent  type  of  actual  type. 


with  Test  JO;  use  TeztJQ; 
procedure  NotRedefmed  is 

function  ■+■&£  :  integer)  return  integer  is 
begin 

return  L+P.+ 1 ; 
end; 


generic 

type  SomeType  is  range  <>, 
function  Plus(L,R  :  Some  i  ype )  return  ^cme  i ype ; 
function  Plus(L,R  :  SomeType)  return  SomeType  is 
begin 

return  L  *  R;  --  predefined  integer  plus 
end  Plus; 

f ’unction  Plus  Instance  is  new 
Plus(  SomeType = integer ) ; 

begin 

Put  June  ( integer '  image  ( Plus  I  nstance  (3,4))), 
end; 


Type  Parameters 


□  type  identifier  is  range  <>; 

□  type  identifier  is  digits  <>; 

□  type  identifier  is  delta  <>; 

□  type  identifier  is  (<>); 

□  type  identifier  is  ar r ay ( typemark range  <>, 

.  .  typemark  range  <>)  of  typemark 

□  type  identifier  is  arrav(  typemark  .... 

typemark)  of  typemark 


□  type  identifier  is  access  typemark 

□  type  identifier  is  private; 


D  type  identifier  is 
*  no  SUBtypes 


limited  privat 


Integer  Type  Parameters 


□  type  identifier  is  range  <>; 

□  matches  an  integer  type,  predefined  or 
user-defined 

□  operations  defined  are  those  defined  for 

integers  such  as  rem,  mod, 

negation,  abs,  >,  <,  «,  /-,  <=,  >« 

□  attributes  defined  are  those  defined  for 
integers  such  as  first,  last,  succ,  .  .  . 


Integer  Type  Parameters 
An  Example 


generic 

type  IntType  is  range  <>; 
function  Increment^  :  IntType)  return  IntType; 

function  Increment(X.TntType)  return  IntType  is 
begin 

return  X+ 1; 
end  Increment; 

with  Increment; 
procedure  IncrementThings  is 

type  Age  is  range  0  ..  1 30; 
type  Temp  is  range  - 1  00  .  .  100: 

MyAge  :  Age  :=  30; 

CurrentTemp  :  Temp  :=  80; 

function  YearOIder  is  new  Increment(Age); 
function  TempUp  is  new 

Increment(IntType=>TempT 


begin 

MyAge  :=  YearOlder(MyAge); 
CurrentTemp  :»  TempUp(CurrentTemp); 
end  IncrementThings; 


Float  Type  Parameters 

□  type  identifier  is  digits  <>; 

□  matches  any  floating  point  type,  predefined 
or  user-defined 

□  operations  defined  are  those  available  for 

floating  point  types  such  as  +  *, 

**,  negation,  abs,  >,  <,  -,  /»,  <«,  >« 

□  attributes  defined  are  those  available  for 
floating  point  types  such  as  ‘small,  ‘large, 
'digits,  mantisa,  ‘epsilon,  .  .  . 

□  useful  in  providing  mathematical  routines 
where  user  can  control  the  precision  used 


Float  Type  Parameters 
An  Example 


generic 

type  FloatType  is  digits  <>; 
function  Sqrt(X  :  FloatType)  return  FloatType; 

function  Sqrt(X  :  FloatType)  return  FloatType  is 
begin 
•  •  • 

end  Sqrt; 
with  Sqrt; 

procedure  Rooting  is 

type  VeryPrecise  is  digits  7; 
type  Imprecise  is  digits  3; 

X  :  VeryPrecise  :=  0.1234: 

Y  :  Imprecise  :=  0.12; 

function  ExactRoot  is  new  Sqrt(VeryPrecise); 
function  RoundRoot  is  new  Sqrt(Imprecise); 

begin 

X  :=  ExactRoot(X); 

Y  :=  RoundRoot(Y); 
end  Rooting; 


Discrete  Type  Parameters 


0  type  identifier  is  (<>); 

□  matches  any  discrete  type  —  includes 
integer  types  and  enumeration  types 
(boolean  also) 

□  attributes  defined  are  those  available  for 
any  discrete/scalar  type  such  as  'first, 
'last,  ‘succ,  'pred,  'image,  'value,  'pos, 

'val 

□  operations  defined  are  those  defined  for 

discrete/scalar  types  such  as  >,  <,  /-, 


Discrete  Type  Parameters 
An  Example 


generic 

type  Element  is  (<>); 
package  Sets  is 
type  Set  is  private; 

function  Intersection^  1,S2  :  Set)  return  Set; 
function  Union(Sl,S2  :  Set)  return  Set; 
function  Isln(ltem  :  Element;  S  :  Set)  return 
boolean; 

function  IsNull(S  :  Set)  return  boolean; 
private 

type  Set  is  array(Element)  of  boolean; 
end  Sets; 


—  some  possible  instantiations 

package  Cha^acterSet  is  new  Sets  (character); 

package  IntegerSet  is  new7  Sets(integer); 

type  Student  is  (John,  Joan,  Ann,  Sue . Zip); 

package  StudentSet  is  new7  Sets(Student); 


Discrete  Type  Parameters  cont. 


□  Minimal  assumptions  about  the  type 
must  be  made  -  operations  must  apply 
to  ALL  discrete  types 


Example: 

generic 

type  Element  is  (<>); 

function  Next(X  :  Element)  return  Element; 

function  Next(X  :  Element)  return  Element  is 
begin 

X  X  +  1;  —  not  defined  for  ALL 

—  discrete  types 

end  Next; 

Use  attributes: 

function  Next(X  :  Element)  return  Element  is 
begin 

if  X  -  Element'Last  then 
return  Element’First; 
else 

return  Element'Succ(X); 
end  if; 
end  Next; 


Constrained  Array  Type  Parameters 


□  type  identifier  is  array  ( typemark 

typemark)  of  typemark 

□  matches  any  constrained  array  type 
where: 

1)  number  of  dimensions  match, 

2)  index  subtypes  of  corresponding 
dimensions  match, 

3)  bounds  in  corresponding  dimensions 
are  identical, 

4)  component  types  match 

□  attributes  defined  are  those  available  for 
constrained  arrays  such  as  ’first(n), 
'last(n),  'range(n),  'length(n) 

□  operations  defined  include  those  available 
for  constrained  arrays  such  as  =,  using 
slice  notation  (for  one  dimensional  arrays) 


Constrained  Array  Type  Parameters 

An  Example 


generic 

type  Index  is  range  <>; 
type  Component  is  (<>); 
type  AnArray  is  array(SM9S)  of  Component; 
—  LRM 12. 1. 2(2)  only  discrete  range  that  is 
—  allowed  is  a  type  mart. ..NOT  (1. .10) etc. 
procedure  Sort(A  :  in  out  AnArray); 
procedure  Sort(A  :  in  out  AnArray)  is 
Temp  :  Component; 
begin 

for  I  in  A'first+ 1  ..  A’last  loop 
for  J  in  ATirst..I-l  loop 
if  A(I)  <  A(J)  then 
Temp  :=  A(J); 

A  ( J)  :=  A  ( I ) ; 

A(I)  :=  Temp; 
end  if; 
end  loop; 
end  loop; 
end  Sort; 


—  in  user  program 
subtype  Small  is  integer  range  1..1Q; 
type  Age  is  integer  range  0..130; 
type  AgeArray  is  array(Small)  of  Age; 

X  :  AgeArray  :=  (3,0,9,4,50,35, $7, 97, 1,1 24) 

procedure  AgeSort  is  new 
Sort(Index=>Small, 

Component=>Age, 

A  n  A  r  ray  =  >  A  ge  A  r  ray ) : 

.  .  .  AgeSort(X);  .  .  . 


Unconstrained  Array  Type 
Parameters 

□  type  identifier  is  ar ray(  tvpemark  rang*  <>, 

....  typemark  range  <>)  of  typemark 

□  matches  any  unconstrained  array  where: 

1)  number  of  dimensions  the  same 

2)  subtype  of  index  for  corresponding 
dimensions  is  the  same 

3)  component  types  match 

□  attributes  defined  are  those  available  for 
unconstrained  arrays  such  as  'first(n), 
'last(n),  'range(n),  'length(n) 

□  operations  defined  include  those  available 
for  unconstrained  arrays  such  as  =, 
using  slice  notation  (for  one  dimensional 
typ  ear  rays) 


Unconstrained  Array  Type 
Parameters 
An  Example 

generic 

type  Index  is  range  <>; 
type  Component  is  range  <>; 
type  AnArray  is  arraydndex  range  <>)  of 
Component; 

procedure  Sort(A  :  in  out  AnArray); 
procedure  Sort(A  :  in  out  AnArray)  is 
Temp  :  Component; 
begin 

for  I  in  A'First+  1  ..  A'Last  loop 
for  J  in  A'First ..  I- 1  loop 
if  A  (I)  <  A(J)  then 
Temp  A(J); 

A ( J)  :«  A(I); 

A(I)  Temp; 
end  if; 
end  loop; 
end  loop; 
end  Sort; 


—  in  user  s  program 

type  Age  is  range  0..  1 30; 
type  EmpioyeeNumber  is  range  1..1G0; 
type  EmpList  is  array(EmployeeNumber  range  <>) 
of  Age; 

procedure  EmployeeAgeSort  is  new 
Sort(Index=>EmployeeNumber, 
Component=>Age, 

AnArray=>EmpList); 

Employees  :  EmpList(5..50)  :«  (.  .  .  .); 

.  .  .  EmployeeAgeSort(Employees);  .  .  . 


Private  Type  Parameters 

□  type  identifier  is  private; 

□  matches  any  constrained  type  except  a 
limited  type 

□  operations  available  are  only  declaring 
objects  of  the  type,  testing  for  equality 
and  inequality,  and  assigning  values  to 
objects  of  the  type 


Private  Type  Parameters 
An  Example 

generic 

type  Index  is  (<>); 
type  Component  is  private; 
type  AnArray  is  array(Index)  of  Component; 
function  Found  (A  :  AnArray;  T  :  Component) 
return  boolean; 

function  Found(A  :  AnArray;  T  :  Component) 
return  boolean  is 
begin 

for  I  in  A'First..A'Last  loop 
if  A(I)  -  T  then 
return  TRUE; 
end  if; 
end  loop; 
return  FALSE; 
end  Found; 


—in  user's  program 

type  Student  is  (Joan.John.Sue,.. ..Debbie); 
type  Grade  is  range  0..100; 
type  GradeArray  is  array(Student)  of  Grade; 
function  GradeMade  is  new 
Found(Index=>Student, 

Component=>Grade, 

A  n  A  r  ray=  >Grad  e  A  rray ) ; 


Grades  :  GradeArray  :=(...  .); 


if  GradeMade(Grades,100)  then  .  .  . 


Private  Type  Parameters  cont. 

and 

Restrictions  Imposed 

What’s  wrong  here? 
generic 

type  Index  is  (<>); 
type  Component  is  private; 
type  InL_Array  is  array(Index)  of  Component; 
procedure  Sort_Array(Arr  :  in  out  InL_Array); 

procedure  Sort_Array(Arr  :  in  out  InL_Array)  is 
Temp  :  Component; 
begin 

for  I  in  Index'Succ(Arr,First)..Arr'Last  loop 
for  J  in  Arr,First..Index'Pred(I)  loop 
if  Arr(I)  <  Ar(J)  then 
Temp  Arr(J); 

Arr(J)  Arr(I); 

Arr(I)  :=  Temp; 
end  if; 
end  loop; 
end  loop; 
end  Sort_Array; 


—in  user  s  program 

type  Student  is  (Joan, John.Sue,... .Debbie); 
type  Grade  is  range  0..100; 
type  GradeArray  is  array(Student)  of  Grade 
function  GradeMade  is  new 
Found  (Index=>Student, 

Component=  >Grade, 

A  n  A  r  ray -  >Gr  ad  e  A  rray ) ; 

Grades  :  GradeArray  >  (.  .  .  .); 

.  .  .  if  GradeMade(Grades.lOO)  then  .  .  . 


Private  Type  Parameters 
Another  Caution 


What's  wrong  here? 
generic 

type  Element  is  private; 
procedure  Swap(X,Y  :  in  out  Element); 

procedure  Swap(X,Y  :  in  out  Element)  is 
Temp  :  Element; 
begin 
Temp  :=  X; 

X  Y; 

Y  Temp; 
end  Swap; 


—  in  user  s  program 

HerName  :  string(1..5)  :=  "Lindy"; 

HisName  :  string(1..5)  :=  "Chuck"; 

procedure  NameSwap  is  new  Swap(string) 


?????????????????????????????????????????????? 

7777777777777777777777777777777777777777777777 


procedure  NameSwap(X,Y  :  in  out  string)  is 
Temp  :  Stiffiiaig;  --  OOPS! 
begin 
Temp  :=  X; 

X  Y; 

Y  :=  Temp; 
end  NameSwap; 


generic 

type  Element  is  private; 
procedure  Swap(X,Y  :  in  out  Element); 

procedure  Swap(X,Y  :  in  out  Element)  is 
Temp  :  constant  Element  >  X; 
begin 
X  :=  Y; 

Y  :=  Temp; 
end  Swap; 


procedure  NameSwap(X,Y  :  in  out  string) 
Temp  :  eosiaSMJ  QSffSl&g  X; 
begin 
X  Y; 

Y  :=  Temp; 
end  NameSwap; 


Limited  Private  Type  Parameters 

□  matches  any  type  including  a  limited 
type 

□  only  declaration  of  objects  of  the  type 
permitted  and  NOTHING  else 


Access  Type  Parameters 


□  matches  any  access  type 

□  operations  defined  for  access  types 
available  such  as  setting  object  to  null, 
use  of  NEW  allocator,  use  of  .ALL  notation 


Access  Type  Parameters 
An  Example 


aeneric 

type  Node  is  private; 
type  Link  is  access  Node; 
package  List  is 

end  List; 


type  STudent; 

type  StudentPointer  is  access  Student; 
type  STudent  is 
record 


NextStudent,  PriorSludenl 
Name  :  stnngd  ..20/: 

Age  :  integer; 
end  record; 


Cr 


luoer.ir'oini 


package  StudentPackage  is  new 
List(Ncde=>Student,  Link=>5 


-tudentPointer) 


Generic  Formal  Type  Parameters 

A  Synopsis 

Generic  formal  parameter  Actual  parameter 

type  T  is  limited  private;  any  type 
type  T  is  private;  any  non- limited  type 

type  T  is  (<>);  any  discrete  type 

type  T  is  rangeo;  any  integer  type 

type  T  is  digits  <>;  any  float  type 

type  T  is  delta  <>;  any  fixed  point  type 


r*T 
t  i 


'aken  from  Ada  Language  and  Methodology  by  Watt.  Wichman, 
and  Findlay] 


Type  Parameters 
and 

The  Standard  Generic  10  Packages 


package  Text_I0  is 

.  . .  non-  generic  part  of  Text_IO 
generic 

type  NUM  is  range  <>; 
package  Integer_IO  is 
•  •  • 

end  Integer_IO; 
generic 

type  NUM  is  digits  <>; 
package  Float_IO  is 
•  •  • 

end  Fioat_IO; 
generic 

type  NUM  is  delta  <>; 
package  Fixed_IO  is 
■  •  • 

end  Fixed_IO; 
generic 

type  ENUM  is  (<>); 
package  EnumerationJO  is 
•  *  • 

end  Enumeration_IO; 
end  Text_IO: 


How  Do  I  Choose??? 


type  X  is  digits 


type  X  is  range  <. 


type  X  is  limited  private; 


Subprogram  Parameters 
An  Example 


generic 

type  Index  is  (<>); 
type  Component  is  private; 
type  Int_Array  is  array(Index  range  <>)  of 
Component; 

with  function  V(X,Y:Component) 
return  boolean; 

procedure  Sort_Array(Arr  :  in  out  Int_Array); 

procedure  Sort_Array(Arr  :  in  out  Int_Array)  is 
Temp  :  Component; 
begin 

for  I  in  Index'Succ(Arr'First)..Arr'Last  loop 
for  J  in  Arr'First..Index'Pred(I)  loop 
if  Arr(I)  <  Ar(J)  then 
Temp  Arr(J); 

Arr'J)  Ar.  (!); 

Arr(i)  Temp; 
end  if; 
end  loop; 
end  loop; 
end  Sort-Array; 


Generic  Formal  Type  Parameters 
How  T o  Choose  ? 


□  What  operations  are  performed  on  the 
type  in  the  generic  body? 

□  How  restrictive  on  the  type  that  the  user 
can  choose  do  you  want  to  be? 


Subprogram  Parameters 


□  allow  definition  and  "pass  in"  of 
additional  operations  for  generic 
formal  type  parameters  -  especially 
private  and  limited  private  types 

□  can  pass  functions  or  procedures 

□  formal  parameters  of  generic  formal 
subprogram  parameter  are  checked  to 
ensure  match  with  actual  parameters 
in  a  call  to  that  subprogram  at  compile 
time 


Subprogram  Parameters 


StudentRec 
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Subprogram  Parameters  -  cont. 


type  Anlndez  is  range  1 ..  1 00; 

type  StudentRec  is  record 
Age  :  natural, 

QPR  ;  float; 

StudentNumber  :  natural; 
end  record; 

type  Student  Array  is  array  (An  Index  range  <>)  of  StudentRec; 

function  LTtX.Y :  StudentRec)  return  boolean  is 
begin 

return  XStudentNumber  <  Y StudentNumber; 
end  IT, 

function  "<“(X,Y  :  StudentRec)  return  boolean  is 
begin 

return  X.QPR  <  Y  QPR; 
end  “<"; 


Drocedure  N'amberSort  is  new  Sort_Arro*’ 

*  • 

!  ^ ••  —  V  ^  ^  «•  *3  <■»  •*  ^  •“  *•  »*  «  V  (O *  •  •  ^  *  n  ^  — 

\  *  a  i  —  '  r* k*  **•  IvJCa  t  *  1  iJv'*  iwl  1  L  “  /  O  U  V«J.O  W*  i  ; 

AnArr ay: =>Student Array,  =  37); 


procedure  QPR_Sort  is  new  Sort-Array 
( Index=>Aninaex,  Component=>StudentRec, 
AnArray=>StudentArray,  "<"  =>  ”<M); 

StudentData  :  StudentArray(  1  ..30)  :=(....); 
begin 

NumberSort(StudentData); 

QPR_Sort  ( StudentData ); 
end, 


Subprogram  Parameters 

and 

Default  Values 


generic 

type  Index  is  (<>); 
type  Component  is  private; 
type  Int_Array  is  array(Index  range  <>)  of 
Component; 

with  function  V(X,Y:Component) 
return  boolean  3a  o; 

procedure  Sort_Array(Arr  :  in  out  AnArray); 


—  in  user's  program 

function  V(X,Y  :  StudentRec)  return  boolean 
begin 

return  X.QPR  <  Y.QPR: 

4  H  It 

end  <  ; 

procedure  DefaultSort  is  new  Sort_Arrav 
(Index=>AnIndex,Component=>StudentRec, 
AnArray=>StudentArray); 


DefaultSort(StudentData);  —  will  sort  on 

—  QPR  values 


Subprogram  Parameters 

and 

Default  Values 


—in  user's  program 

function  LessThan(X,Y  :  StudentRec)  return 
boolean  is 
begin 

return  X.QPR  <  Y.QPR; 
end  LessThan; 

generic 

type  Index  is  (<>); 
type  Component  is  private; 
type  Int-Array  is  arrayUndex  range  <>)  of 
Component; 

with  function  V(X,Y:Com?onent'i 
return  boolean  taggsIHsIBl; 
procedure  Sort_Arrav(Arr  :  in  out  AnArravi; 

procedure  DefaultSort  is  new  Sort— Arrav 
( Index=  >  AnIndex,Component=  >StudentRec , 
AnArray*>Student  Array); 


DefaultSort(StudentData);  —  will  sort  on 

--  QPR  values 


Subprogram  Parameters 

and 

Default  Values  cont. 


Another  example: 

type  SmailRange  is  range  1..10; 
type  Values  is  array  (SmailRange  range  <>)  of 
integer; 

procedure  IntegerSort  is  new  Sort_Array 
(Index- >SmallRange,  Component->integer, 
Int_Array-  >V  alues ) ; 


V  :  Values (5. .9) :-(... .); 
begin 

IntegerSort(V);  —  default  "<"  for  integers  used 
end; 

—  using  Put  for  subprogram  parameter  name 

—  results  in  default  to  generic  Put  routines 

—  in  the  10  packages 


Subprogram  Parameters 

and 

Subtleties  of  Default  Values 


□  Global  references  inside  a  generic  are 
resolved  to  those  at  point  of  DECLARATION 

□  For  subprogram  parameters,  default 
references  resolve  to  matching  names  from 
point  of  INSTANTIATION. 


NAMING  CONFUSION 


with  Text_I0;  use  Text_IO; 
procedure  Doubles  is 

generic 

with  procedure  M|pKSsiB9<Char  :  in  character)  ; 
with  procedure  ■oaariMSSBav  (Value:  in  integer); 
procedure  GenericOne; 

procedure  GenericOne  is 
begin 

DoSomething ( '  A  ’ ) ; 

DoSomething ( 10 ) ; 
end  GenericOne; 


procedure  FirstSomething(Char  :  in  character)  is 
begin 
nul  1 ; 

end  FirstSomething; 


procedure  SecondSomething (Char 
begin 
null  ; 

end  SecondSomething; 


in  integer)  is 

/ 


procedure  InstanceOfGenericOne  is  new 

GenericOne^VBBKttiaa^,>>FirstSomething 


r=>S  econdSome  thing  )j 


begin 

InstanceOfGenericOne ; 
end  Doubles ; 


with  TextJO;  use  Text_IO; 
package  Shell  is 
Global  :  integer  >17; 
generic 

with  procedure  Put(Val  :  integer)  is  <>; 
procedure  Demo; 
end  Shell; 

package  body  Shell  is 
procedure  Demo  is 
begin 

Put(Global); 
end  Demo; 
end  Shell; 


with  Shell; 
package  Inner  is 
Global  :  integer  >  39; 
procedure  Put(I  :  integer); 

procedure  User  is  new  Shell. Demo; 
end  Inner; 


with  Text_IO; 
package  body  Inner  is 
procedure  Put(I  :  integer)  is 
begin 

Text_IO.Put(  "Surprise"  &  integer' image(I)); 
end  Put; 
end  Inner; 


.  .  .  Inner. User;  . 


Subprogram  Parameters 

and 

Nesting  Generic  Units 
An  Example 

generic 

type  KeyType  is  private; 
type  ElementType  is  private; 
with  function  V (Left, Right :  KeyType) 
return  boolean  is  <>; 
package  BinaryTreeMaker  is 
type  Kind  is  private; 
function  Make  return  Kind; 
function  IsEmpty(T  :  Kind)  return  boolean; 
procedure  Insert(T  :  in  out  Kind; 

K  :  KeyType; 

E  :  ElementType); 

function  Retrieved  :  Kind;  K  :  KeyType) 
return  ElementType; 

KeyNotFound  :  exception; 

generic 

with  procedure  Operation(K  :  KeyType; 

E  :  ElementType); 

procedure  lnorderTraverse(TheTree:  in  Kind); 
private 

type  InternalRecord; 
type  Kind  is  access  InternalRecord; 
end  BinaryTreeMaker; 


with  EmploveeDataBase;  use  EmpioyeeDataBase; 
with  Text_IO;  use  Text_IO; 
procedure  PrintReports  is 

package  SalarylO  is  new  Fixed_IO(Doilar); 
package  AgeiO  is  new  Integer_IO(AgeTvpe); 
use  SalarylO,  AgeiO; 

procedure  PrintSalarv(Key  :  NameType; 

Info  :  Employeelnfo)  is 
begin 

.  .  .  Put(Info. Salary); 
end; 

procedure  Print  Age(Key  ;  NameType; 

Info  ;  Employeelnfo)  is 
begin 

.  .  .  Put(Info.Age); 
end; 

procedure  ReportSalaries  is  new 
EmployeeTree.InorderTraverse 
(Operation-)  PrintSaiary); 

procedure  ReportAge  is  new 
EmployeeTree.InorderTraverse 
(Operations  PrintAge); 

begin 

ReportSalaries(RootNode); 

New_Line; 

Report  Ages(RootNode); 
end  PrintReports; 

T  4  A  m  »  -J  S“A  1 


with  BinaryTreeMaker; 
package  EmployeeDataBase  is 
NameLength  :  constant  :=  40; 
subtype  NameType  is  stringd.. NameLength); 
type  Dollar  is  delta  0.01  range  0.0..1.0eS; 
type  AgeType  is  range  0  ..  150; 
type  YearType  is  range  1 900..2 1 00; 
type  Employeelnfo  is  record 
Salary  :  Dollar; 

Age  :  AgeType; 

Hired  :  YearType; 
end  record; 

package  EmployeeTree  is  new 

BinaryTreeMaker(KeyType«>MameType, 

ElementType=>EmploveeInfo); 

RootNode  :  EmployeeTree. Kind; 
end  EmployeeDataBase; 


[Taken  from  Understanding  Ada  bv  Brav  arid  Pokrassl 

w  *  t 


Subprogram  Parameter 

and 

Handling  Exceptions 

generic 

package  Stack  is 
. .  .  same  as  before 

Overflow,  Underflow  :  exception; 
end  Stack; 

—  in  user's  program 

package  SI  is  new  Stack; 
package  S2  is  newT  Stack; 

begin 

51. Push(5); 

52. Pop(Item); 
exception 

when  SI. Underflow 
when  SI. Overflow  =>...; 
when  S2. Underflow 
when  S2. Overflow  =>...; 
end 


Subprogram  Parameters 

and 

Handling  Exceptions  cont. 


□  Cannot  pass  exceptions  as  generic  parameter 


generic 

When_Error  :  exception;  —NOT  allowed 

•  •  a 

procedure  X  .  . . 

•  •  • 

exception 

when  others  *>  raise  When_Error; 
end  X; 


My  ^Exception  :  exception; 
procedure  S  is  new  X(MyJException); 

•  •  * 
begin 
S; 

exception 

when  My_Exception  =>  .  . —  NOT  allowed 
end; 


Subprogram  Parameters 

and 

Handling  Exceptions  cont. 


generic 

with  procedure  OverflowHandler; 
package  Stack  is 
. .  .  same  as  before; 
end  Stack; 

package  body  Stack  is 

...  in  Push  procedure  .  .  . 
when  Constraint_Error  ->  OverflowHandler; 

end  Stack; 

—  in  user  program 
with  Stack; 

•  a  • 

procedure  OverflowHandler  is 
begin 

Text_JO.Put_Line(  "Overflow  has  occurred"); 
end  OverflowHandler; 

package  SI  is  new  Stack(OverflowHandler); 

begin 
•  •  • 

Sl.Push(5);  --  if  overflow  occurs  msg  prints 
end; 


Generic  Can'ts 


□  No  generic  SUBtype  parameters,  only  TYPEs 

□  No  generic  record  types 

□  No  generic  tasks 

□  Wrap  a  package  around  it 

□  .  Ada  provides  formal  types  for  all 

classes  of  type  SS3& 

types.  The  major  reason  for  this  is  that 

it  is  not  clear  that  reasonable  criteria  for 
matching  exist  for  these  type  classes  - 
criteria  that  would  be  consistent  with  the 
degree  of  type  checking  performed 
elsewhere,  yet  at  the  same  time  have  a  good 
probability  of  being  usable  for  many  actual 
record  types  and  task  types."  LRM  12.4.2 


I  £  ^  ks  ^  vy  i  !  r  i  i 


yv  r  a  r\ 

U  II!!  I1 


ir  par 


generic 

type  Item  is  private; 

Size  :  Positive  :=  400; 
package  On_Buffers  is 
task  type  Buffer  is 
entry  Read(C  :  out  Item); 
entry  Write(C  :  in  Item); 
end; 

end  On_Buffers; 


K  a  a  s  /  I  'in  U  i  i  f  f  a  m  p  i  c 
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type  Length  is  new  Integer  range  1 ..  Size; 


rV/^  Vector  is  arraydength  range  <>)  of  item; 


f  ■.  /  n  a  \j 
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Poo!  ;  Vectord  ..  Size); 

Count  :  Natural  :=  0; 

InJndex,  OutJndex  :  Length  :=  1; 


»*v.  .*"»  y 

L1  v  U  i  !  ! 
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se  i  ec  l 


when  Count  <  Size  => 
accept  writeCC:  in  Item)  do 
PooKinJndex)  :=  C; 
end; 

InJndex  :=  (InJndex  mod  Size)  +  1 ; 


or 


CO 


when  Count  >  0  => 
accept  Read(C  :  out  Item.)  do 
C  :=  PooKOutJndex); 
end; 

OutJndex  :=  (OutJndex  mod  Size)  +  1; 
Count  :=  Count  -  1 ; 
or 

terminate; 
end  select; 
end  loop; 
end  Buffer; 
end  On-Buffers; 


package  Character_Buffering  is  new 

On_Buffers(ltem=>character,  Size=>  1 00); 

A_Buffer  :  Character_Buffering.Buffer; 


[Taken  from  Ada  Rationale] 


Generic  Formal  Parametei 


and 


Q  f  p  r  i  r  !  i 

o  c  O  o  i  \w  ^ 


ses 


□  Generic  formal  parameters  and  their 
attributes  NOT  allowed  constituents 
of  static  expressions. 


u  No  use  in  case  alternatives,  type  ranges, 
floating  point  precisions,  etc.  (See  LRH 
4.9) 


Hpr  ! 

UV'wlWl  ’w' 

nonprjr 
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X  : integer; 
procedure  Choice(Vai 
procedure  ChoicefVsi 

horUn 

v  yi  i  1 

case  Val  is 
when  X  =>  .  .  . 
when  others  =>  .  . 
end  case; 
end  Choice; 


integer); 
integer)  is 


ill  OfCil  i  iC:  onp 
J  I  i  i  U+DCiUZ- 


procedure  Testinstance  is  new  Choice(X=>5), 


begin 


est!nstance(Val=>8): 


Generic  Formal  Parameters 

ana 

Static  Uses  (continued) 


declare 
generic 
X  :  inteaer; 

package  MoreJUegalJJses  u 
type  Length  is  range  1 ..  X; 

f  \/  n  c  Drpricipn  i  c  H  i  i  f  c  Y  • 
lY  |J^  ii  jiui  i  I  _i  uii^i  lj  A, 

N  :  constant  :=  X; 
end  MoreJilegaLUses; 

package  S  is  new  MoreJlleg* 


_U  s  e  s  ( p )  ( 


What  are  the  Cons  of  Generics? 


□  Takes  longer/is  harder  to  write  generic  code 

□  Usually  some  efficiency  sacrificed  for 
the  generality  —  use  of  application 
specifics  could  lead  to  increased  efficiency 

□  Difficult  to  make  component  robust/reliable 
enough  to  survive  all  uses 


What  are  the  Pros  of  generics? 

□  Reusability  -  no  reinventing  the  wheel 
for  each  specific  application 

□  Levels  of  abstraction  added  -  separation 
of  abstraction  and  implementation 

□  Source  code  size  of  user  programs  reduced 

□  Maintainability,  readability,  and 
understandability  increased 

□  Verification  more  manageable 

□  When  used  in  conjunction  with  user-defined 
types  increases  portability  across  machines 

□  Provides  necessary  answer  to  strong  typing 
without  sacrificing  increased  reliability  of 
compile  time  checks 

□  Provides  flexible  10  packages  which  can 
he  used  (if  needed]  for  predefined  AND 
user-defined  types 


Generics  Philosophy 

(From  Ada  Rationale) 

.  .  Whereas  such  packages  are  likely 

to  be  utilized  by  LARGE  classes  of  USERS, 

it  should  be  realized  that  FEWER 

programmers  will  actually  be  involved  in 

WRITING  generic  packages.  Accordingly 

we  have  tried  to  design  a  facility  that  can 

be  almost  ignored  by  the  majority  of  users 

They  must  indeed  know  how  to  instantiate 

a  generic  package,  and  this  is  fairly  easy. 

On  the  other  hand,  thev  need  not  he 

¥ 

familiar  with  the  rules  and  precautions 
necessary  for  writing  generic  units.” 


Generics 

"Users 
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Generics 
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Rationale  for  Generics 


□  Construction  of  general-purpose 


parameterized  packages,  procedures 


a  r. 


.  H 


Gnu 


function; 


□  Units  to  be  used  by  large  classes  of  user! 


□  Fewer  programmers  actually  involved  in 


writina  Generic  units 


n  a.  a 


Generic  facility  can  be  ignored  by 
majority  of  Ada  users 

□  Most  users  only  need  know  how  to 
instantiate  a  Generic  unit 


J  Mi  e  LUriLCAL-UCU^I  IUCI  it  C/\  Lt?no  I  Ui  i  Ui 
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□  Well  implementabie  within  state  of  am 


More  on  the  Generic  Model 


□  Users  of  generic  units  should  be  able  to 
ignore  details  of  generic  body  entirely 

□  Errors  should  be  reported  to  user  in 
terms  of  the  instantiation  not  body 

□  Generic  body  checked  for  consistency 
with  respect  to  formal  parameter 
specifications 


Unresolved  Issues  in  Generics 


□  Compiler  Issues 

□  Use  "code  sharing"  or  "code  copying"  to 
implement  generics 

□  Management  Issues 

□  How  to  facilitate  creation  of  generic  units 

D  In  retrospect,  after  recognizing 
similarity  in  produced  units 
□  Beforehand  using  "domain  analysis" 

□  How  to  manage  storage  and  retrieval 
of  units  in  a  library  of  generic  units 

D  How  to  "publicize"  availability  of 
units  in  generic  library  and  provide 
criterion  for  selecting  proper  unit 

□  How  to  manage  updating  of  used  generic 
units  as  "bugs"  are  uncovered 

□  Legal  Issues 

□  Who  owns  the  generic  module 

□  Who  is  liable  for  the  generic  module's 
performance 


fio)r ic 


uff^'ype  E  is  private; 
/procedure  X; 

procedure  X  is 
begin 


end  X; 


How  do  you  TEACH  generics? 


□  Necessary  as  10  is  an  issue  arising  early 
and  should  not  be  kept  a  "magic”  process 

□  One  key  is  to  use  concrete  examples 

□  Driver  s  licence  form  is  a  generic 
template  —  individual's  license  is 
a  usable  instantiation 

□  One  key  is  to  tie  to  previous  learning 

□  Use  old/familiar  packages,  procedures, 
and  functions  -  Stacks,  Swap,  etc. 


with  Text_IO,  Binary _Search_Trees ;  use  Text_IO; 
procedure  MidTree  is 

type  AlphaType  is  range  1..4000; 
type  CompanyType  is  range  1..36; 
subtype  NameType  is  string (1.  .20)  ; 
subtype  MajorType  is  string (1 .. 4 ) ; 

type  MidRec  is  record 
Alpha  :  AlphaType; 

Name  :  NameType ; 

Company  :  CompanyType ; 

Major  :  MajorType; 

end  record; 

package  AlphalO  is  new  Integer_IO (AlphaType) ; 
package  CompanylO  is  new  Integer_IO (CompanyType) ; 
use  AlphalO,  CompanylO; 

MidFile  :  File_Type; 

MRec  :  MidRec ; 

package  MidTreePkg  is  new  Binary _Search_Trees  (Itemtype*=>MidRec) 
use  MidTreePkg; 

MidshipmanTree  :  Tree; 

function  "<" (Left, Right  :  in  MidRec)  return  boolean  is 
begin 

return  Left. Name  <  Right. Name; 
end  "<"; 

procedure  Add  is  new  Insert ("<"=>"<") ; 

procedure  Print (M  :  in  out  MidRec)  is 
begin 

Put_Line (M. Name) ; 
end  Print; 

procedure  Namelist  is  new  LNR_Traversal (Visit=>Print) ; 


begin 

Open (MidFile, In_Fiie, "sys$fac: [moran.play]mids.dat") ; 
while  NOT  end_cf_file (MidFile)  loop 
Get ( MidFile, MRec. Alpha) ; 

Get (MidFile, MRec. Name) ; 

Get (MidFile, MRec. Company) ; 

Get (MidFile, MRec. Major) ; 

Skip_Line (MidFile) ; 

Add (MidshipmanTree, MRec) ; 
end  loop; 

Close (MidFile) ; 


NameList (MidshipmanTree) ; 
end ; 


with  Text_IO,  Binary _Search_Trees ;  use  Text_IO; 
procedure  MoviesTree  is 

type  CategoryType  is  (AD,  DR,  CL,  SF,  MU,  MY) ; 
subtype  IDType  is  string (1 .. 5)  ; 
subtype  LengthType  is  integer  range  0..300; 
subtype  YearType  is  integer  range  1800.. 1988; 
type  RatingType  is  ( PG , R , G , NR ) ; 
subtype  TitleType  is  string (1. .80) ; 


type  MovieRec 
Category  : 
ID  : 

Length  : 
Rating  : 
Year  : 

Title  : 
end  record; 


is  record 

CategoryType ; 

IDType; 

LengthType ; 

RatingType; 

YearType; 

Titletype; 


package  IntIO  is  new  Integer_IO ( integer) ; 
package  CategorylO  is  new  Enumeration_IO (CategoryType) ; 
package  RatinglO  is  new  Enumeration_IO (RatingType) ; 
use  IntIO,  CategorylO,  RatinglO; 


MovieFile  :  File_Type; 

MRec  :  MovieRec; 

Filler  :  character; 

Count  :  natural ; 

Temp  :  string ( 1 .. 80) ; 

Blanks  :  string(l. . 80)  :=  (others=>'  '); 

Commando,  Bearlsland,  Daniel,  Flashpoint,  MassAppeal  :  MovieRec; 

package  MovieTreePkg  is  new  Binary _Search_Trees (Itemtvpe=>MovieRec 
use  MovieTreePkg; 


MovieTree  :  Tree; 


function  "<"  (Left, Right  :  ir.  MovieRec)  return  boolean  is 
begin 

return  Left. Title  <  Right. Title; 
end  "<"? 


-  i  w  -  *  —  *6  v  -“,C’  —  w  t  *'•  —  '3  - 

begin 

return  Left. Title  = 
end  EQ; 


MovieRec) 


Right. Title ; 


return  boolean  is 


procedure  Add  is  new  InsertByKey  (,,<"=>"<")  ; 

procedure  Print (M  ;  in  out  MovieRec)  is 
begin 

Put_Line (M. Title)  ; 
end  Print; 


procedure  NameList  is  new  LNR_Traversal (Visit=>Print) ; 
procedure  Remove  is  new  RemoveByKey ("<"=>"<" ,EQ=>EQ) ; 
begin 

Commando. Title  :=  Blanks; 


Daniel  .Title  (l. .  6)  ''Daniel"; 

Flashpoint. Title  :=  Blanks? 

Flashpoint. Title(l. .10)  :«  "Flashpoint"; 
MassAppeal. Title  :*  Blanks; 

MassAppeal. Title (l. .11)  :«  "Mass  Appeal"; 

Open(MovieFile, In_File, "movies.dat") ; 
while  NOT  end_of_f ile (MovieFile)  loop 
Get (MovieFile, MRec. Category) ; 

Get (MovieFile, Filler) ; 

Get (MovieFile, MRec. ID) ; 

Get (MovieFile, Filler) ; 

Get (MovieFile,  MRec. Length) ; 

Get (MovieFile, Filler) ; 

Get (MovieFile, MRec. Rating)  ; 

Get (MovieFile, Filler)  ; 

Get (MovieFile, MRec. Year) ; 

Get (MovieFile, Filler)  ; 

Get_Line (MovieFile, Temp, Count) ; 

MRec. Title  :=  Blanks; 

MRec. Title  (1.  .Count)  ;*=  Temp (1.  .  Count)  ; 
Add (MovieTree, MRec) ; 
end  loop; 

Close (MovieFile)  ; 

NameList (MovieTree) ; 

Remove (MovieTree, Bearlsland) ; 

Remove (MovieTree , Daniel ) ; 

Remove (MovieTree, Flashpoint) ; 

Remove (MovieTree, MassAppeal) ; 

Remove (MovieTree, Commando) ; 

NameList (MovieTree) ; 
end; 


generic 

type  ItemType  is  private; 
package  Binary _Search_Trees  is 

type  Tree  is  private? 

generic 

with  function  "<" (Left,Right  ;  in  Itemtype)  return  boolean  is  <> 
procedure  Insert By Key (T  :  in  out  Tree;  Item  :  in  Itemtype) ; 

generic 

with  procedure  Visit(Item  :  in  out  Itemtype); 
procedure  NLR_Traversal (T  :  in  Tree); 

generic 

with  procedure  Visit(Iteir.  :  in  out  Itemtype); 
procedure  LNR_Traversal (T  :  in  Tree); 

generic 

with  procedure  Visit (Item  :  in  out  Itemtype) ; 
procedure  LRN_Traversal (T  :  in  Tree); 

procedure  Share (Or iginalTree  ;  in  Tree;  SharingTree  :  out  Tree); 

procedure  Clear (T  :  out  Tree) ; 

generic 

with  function  EQ (Left , Right  :  in  Itemtype)  return  boolean; 
with  function  "<" (Left , Right  :  in  Itemtype)  return  boolean; 
procedure  RemoveByKey (T  :  in  out  Tree?  Item  :  in  Itemtype); 


function 

Left_Son (T 

:  in  Tree) 

return  Tree; 

function 

Right_Son (T 

:  in  Tree) 

return  Tree; 

function 

Is Empty (T  ; 

in  Tree)  r 

■eturn  boolean; 

function 

O  CO  UUG  u.Ck 

(T  :  in  Tree)  return  ItemType; 

Out_Cf ^Memory  ;  exception; 
Kul__Tree  :  exception; 


private 

type  TreeStructure ; 
type  Tree  is  access  TreeStructure; 
end  Einary_Search_Trees ; 

package  body  Binary_Search_Trees  is 

type  TreeStructure  is  record 
Item  :  Itemtype; 

Lefts on  :  Tree  ;=  null; 
RightSon  ;  Tree  :=  null; 
end  record; 


procedure  InsertByKey (T  :  in  out  Tree;  Item  :  in  Itemtype)  ir 
begin 

if  T  =  null  then 

—  found  leaf  position  where  Item  to  be  inserted 

—  create  new  leaf  and  insert  it 


else 

—  go  down  right  subtree 
InsertByKey (T.RightSon, Item) ; 

end  if; 

exception 

when  Storage_Error  =>  raise  Out_Of_Memory ; 
end  InsertByKey; 

procedure  NLR_Tr aver sal (T  :  in  Tree)  is 
begin 

if  T  /=  null  then 
Visit (T. Item) ; 

NLR_Traversal (T. LeftSon) ; 

NLR_Traversal (T.RightSon) ; 
end  if; 

end  NLR_Traversal ; 

procedure  LNR_Traversal (T  :  in  Tree)  is 
begin 

if  T  /-  null  then 

LNR_Traversal (T. LeftSon) ; 

Visit (T. Item) ; 

LNR_Traversal (T.RightSon) ; 
end  if; 

end  LNR_Traversal ; 

procedure  LRN_Traversal (T  :  in  Tree)  is 
begin 

if  T  /=  null  then 

LRN_Traversal (T. LeftSon) ; 

LRN_Tr a versa 1 (T.RightSon) ; 

Visit (T. Item) ; 
end  if; 

end  LRN_Traversal ; 

procedure  Share (OriginalTree  ;  in  Tree;  SharingTree  :  out  Tree)  is 
begin 

SharingTree  :=  OriginalTree; 
end  Share; 

procedure  Clear (T  :  out  Tree)  is 
begin 

T  :=  null; 
end  Clear; 

procedure  Remove3yKey (T  :  in  out  Tree;  Item  :  in  ItemType)  is 
Father,  Replacementltem  :  Tree; 
begin 

if  T  =  null  then 

—  do  nothing. .. item  not  in  the  tree 
null ; 

elsif  EQ(Item,  T.Item)  then 

if  (T.RightSon=null)  and  (T.LeftSon=null)  then 

—  item  is  a  leaf... no  reattachment  of  children  necessary 
T  :=  null; 

else  —  item  not  a  leaf 

—  go  left  and  then  right  as  far  as  possible  to  find 

—  replacement  "value"  to  put  in  deleted  place 
if  T. LeftSon  /=  null  then 

Father  :=  T; 

Replacementltem  :=  T. LeftSon; 


—  transfer  replacement  value  up  into  position 
T.Item  : *  Replacementltem. Item; 

—  reattach  children  of  replacement  value  that 

—  was  pulled  up 
if  Father  =  T  then 

T.LeftSon  :=  Replacementltem. LeftSon ; 
else 

Father .RightSon  :=  Replacementltem. LeftSon ; 
end  if; 
else 

—  go  right  and  then  left  as  far  as  possible  to  find 

—  replacement  "value"  to  put  in  deleted  place 
Father  :=  T; 

Replacementltem  :=  T. RightSon; 
while  Replacementltem. LeftSon  /=  null  loop 
Father  :=  Replacementltem; 

Replacementltem  :=  Replacementltem. LeftSon : 
end  loop; 

—  transfer  replacement  value  up  into  position 
T.Item  :=  Replacementltem. Item; 

—  reattach  children  of  replacement  value  that 

—  was  pulled  up 
if  Father  =  T  then 

T. RightSon  :=  Replacementltem. RightSon ; 
else 

Father . LeftSon  :=  Replacementltem . RightSon ; 
end  if; 
end  if; 
end  if; 

elsif  Item  <  T.Item  then 

—  go  down  left  subtree 
RemoveByKey (T. LeftSon, Item) ; 

else 

—  go  down  right  subtree 
RemoveByKey (T. RightSon, Item) ; 

end  if; 

end  RemoveByKey; 

function  Left_Son(T  :  in  Tree)  return  Tree  is 
begin 

if  T  =  null  then 

raise  Nuli_Tree; 

else 

return  T.LeftSon; 
end  if; 
end  Left_Son; 

function  Richt_Son(T  :  in  Tree)  return  Tree  is 
begin 

if  T  =  null  then 
raise  Null_Tree; 
else 

return  T. RightSon; 
end  if; 

end  Right_Son; 

function  IsEmpty(T  :  in  Tree)  return  boolean  is 
begin 

return  T  =  null; 
end  IsEmpty; 

function  GetRootData (T  :  in  Tree)  return  ItemType  is 


return  T .  1 1 em ; 
end  if; 

end  GetRootOata; 
end  Binary_Search_Trees ; 


with  Lists,  Text_IO;  use  Text_IO; 
procedure  MoviesList  is 

type  CategoryType  is  (AD,  DR,  CL,  SF,  MU,  MY)  ; 
subtype  IDType  is  string (1. .5) ; 
subtype  LengthType  is  integer  range  0..300; 
subtype  YearType  is  integer  range  1800.. 1988; 
type  RatingType  is  (PG , R, G , NR) ; 
subtype  TitleType  is  string ( l .. 80) ; 

type  MovieRec  is  record 

Category  :  CategoryType ; 

ID  :  IDType; 

Length  :  LengthType ; 

Rating  :  RatingType; 

Year  :  YearType; 

Title  :  Titletype; 

end  record; 

package  IntIO  is  new  Integer__IO  (integer)  ; 
package  CategorylO  is  new  Enumeration_IO (CategoryType)  ; 
package  RatinglO  is  new  Enumeration_IO (RatingType) ; 
use  IntIO,  CategorylO,  RatinglO; 

MovieFile  :  File_Type; 

MRec  :  MovieRec ; 

Filler  :  character; 

Count  :  natural ; 

Temp  :  string (1. .80) ; 

Blanks  ;  string ( 1. . 80)  ;=  (other s=> '  '); 

function  Get_Title (Movie  :  MovieRec)  return  Titletype; 
function  "<" (Left,  Right  :  TitleType)  return  boolean; 
function  EQ(Left,  Right  :  TitleType)  return  boolean; 

package  MovieListPkg  is  new  Lists (Item=>McvieRec, 

KeyTvpe=>TitleTvpe , 

Key=>Get_Title , 
t  r-sivn  rn=vrr  ■  • 

use  MovieListPkg; 

MovieList  :  ListPcinter; 

function  Get_Title (Movie  :  MovieRec)  return  TitleType  is 
begun 

return  Movie. Title; 
end  Get_Title; 

function  "<” (Left, Right  ;  TitleType)  return  boolean  is 
begin 

return  Left  <  Right; 
end  "<"; 

function  EQ (Left , Right  :  TitleType)  return  boolean  is 
begin 

return  Left  =  Right; 
end  EQ ; 

begin 

Open (MovieFile , In_File , "movies . dat" ) ; 


Get (MovieFile, Filler)  ; 

Get (MovieFile, MRec. Length) ; 

Get (MovieFile, Filler) ; 

Get (MovieFile, MRec. Rating) ; 

Get (MovieFile, Filler) ; 

Get (MovieFile, MRec. Year) ; 

Get (MovieFile, Filler) ? 

Get_Line (MovieFile , Temp , Count) ; 

MRec. Title  :=  Blanks? 

MRec. Title (1. .Count)  :=  Temp ( 1 .. Count) ; 
Put (MRec. Title (1. .Count) ) ; 
InsertlnOrderlnList (MovieList , MRec) ; 


end  loop; 

Close (MovieFile) ; 


end ; 


—  Module 

—  Author 

—  Date 

—  Function 


Lists 

LCDR  MORAN 
29  SEP  1987 

Implements  basic  operations  on  a  singly  linked  list. 


generic 

type  Item  is  private; 
type  KeyType  is  private; 


with  function  Key(AnItem  :  Item)  return  KeyType; 
with  function  LE(Keyl,  Key2  ;  KeyType)  return  boolean; 
with  function  EQ (Keyl  Key2  :  KeyType)  return  boolean; 
package  Lists  is 

subtype  Count  is  na+" 

type  ListPointer  ic  privawt, 


procedure  Copy (PointerToOriginalList 

PointerToCopyList 


in  ListPointer; 
out  ListPointer) ; 


procedure  Clear (PointerToTheList  ;  in  out  ListPointer) ; 


procedure  Share (PointerToOriginalList, 

PcinterToSharingList  :  in  out  ListPointer) ; 


procedure  InsertAtHeadOf List (PointerToTheList 

TheltemToBelnserted 

procedure  InsertAtTailOfList (PointerToTheList 

TheltemToBelnserted 

procedure  InsertlnOrderlnList (PointerToTheList 

TheltemToBelnserted 

procedure  RemoveFromHeadOfList (PointerToTheList 

Removedltero 

procedure  RemoveFromTaiiOf List (PointerToTheList 

Removed  I  ter. 

procedure  Remo veBy Key FronList (PointerToTheList 

Removedltem 

KevValue 


in  out  ListPointe 
in  Item) ; 

in  out  ListPointe 
in  Item) ; 

in  out  ListPointe 
in  Iter'  ; 

in  out  ListPointe 
out  Item) ; 

in  out  ListPointe 
c'LT't.  sir. '  r 

in  cut  ListPointe 
out  Item; 
in  KeyType) ; 


function  AreEqual (PointerToLl ,  PointerToL2  :  ListPointer)  return  bocle 

function  IsEmpty (PointerToL  :  ListPointer)  return  boolean; 

function  LengthOf (PointerToL  :  ListPointer)  return  Count; 

function  Predecessor (PointerToAList ,  Pointer! oANode  :  ListPointer) 

return  ListPointer; 

function  Successor (PointerToAList ,  PointerToANode  :  ListPointer) 

return  ListPointer; 


function  GetData (PointerToANode  ;  ListPointer)  return  Item; 


EmptyList  :  exception; 


private 

type  ListNode; 

type  ListPointer  is  access  ListNode; 
end  Lists; 


—  Module  :  Lists 

—  Author  :  LCDR  MORAN 

—  Date  :  29  SEP  1987 

—  Function  :  Implements  basic  operations  on  a  singly  linked  list 

with  Unchecked_Deallocation; 

package  body  Lists  is 

type  ListNode  is  record 
Data  :  Item; 

NextPointer  :  ListPointer; 
end  record; 

function  Successor (PointerToAList ,  PointerToANode  ;  ListPointer) 

return  ListPointer  is 

begin 

return  PointerToANode . NextPointer ; 
end  Successor; 

function  Predecessor (PointerToAList ,  PointerToANode  :  ListPointer) 

return  ListPointer  is 

Prior,  Temp  :  ListPointer  :=  PointerToAList; 
begin 

if  PointerToANode  =  PointerToAList  then 
return  null; 
else 

while  Temp  /=  null  and  Temp  /=  PointerToANode  loop 
Prior  ; —  Temp; 

Temp  :=  Temp. NextPointer ; 
end  loop; 

if  Temp  /=  null  then 
return  Prior; 
else 

return  nul 1 ; 
end  if; 
end  if; 

end  Predecessor; 

function  GetData (PointerToANode  :  ListPointer)  return  Item  is 
begin 

if  PointerToANode  /=  null  then 
return  PointerToANode . Data ; 
end  if; 
end  GetData ; 

procedure  Dispose  is  new  Unchecked_Deallocation (ListNode, ListPcinte 

procedure  Copy  (Pc  ir.terToOriginalList  :  in  ListPointer; 

PointerToCopyList  :  out  ListPointer)  is 

Temp  :  ListPointer  :=  PointerToOriginalList ; 

LastAadedPtr  :  ListPointer; 

NewNodePtr  :  ListPointer; 
begin 

PointerToCopyList  :=  null; 
while  Temp  /=  null  loop 

—  make  the  new  node  and  copy  the  data  into  it 
NewNodePtr  :=  new  ListNode; 

NewNodePtr . Data  :=  Temp. Data; 

if  Temp  =  PointerToOriginalList  then  —  add  the  first  node 
PointerToCopyList  :=  NewNodePtr; 


else 

LastAddedPtr . NextPointer 
end  if; 

Temp  :=  Temp .NextPointer ; 
LastAddedPtr  :=  NewNodePtr; 
end  loop; 
end  Copy; 


—  add  other  than  the  first  noc 
NewNodePtr; 


—  move  to  next  node  in  orig.  1 is 

—  keep  track  of  last  node  added 


procedure  Clear (PointerToTheList  :  in  out  ListPointer)  is 
Temp,  Trail  :  ListPointer  :=  PointerToTheList; 
begin 

while  Temp  /=  null  loop 
Trail  ; =  Temp ; 

Temp  :*=  Temp. Next Po inter ; 

Dispose (Trail) ; 
end  loop; 

PointerToTheList  :=  null; 
end  Clear; 

procedure  Share (PointerToOriginalList , 

PointerToSharingList  :  in  out  ListPointer)  is 

begin 

PointerToSharingList  :=  PointerToOriginalList; 
end  Share ; 

function  IsEmpty (PointerToL  :  ListPointer)  return  boolean  is 
begin 

return  (PointerToL  =  null) ; 
end  IsEmpty; 

procedure  InsertAtHeadOf List (PointerToTheList  :  in  out  ListPointer; 

TheltemToBelnserted  :  in  Item)  is 
PointerToNewNodeToBelnserted  :  ListPointer; 
begin 

PointerToNewNodeToBelnserted  :=  new  ListNode; 
PointerToNewNodeToBelnserted. Data  :=  TheltemToBelnserted; 
if  NOT  IsEmpty (PointerToTheList)  then 

PointerToNewNodeToBelnserted . NextPcinter  : =  PointerToTheList ; 
end  if; 

PointerToTheList  :=  PointerToNewNodeToBelnserted; 
end  InsertAtHeadOfList ; 

procedure  InsertAtTailOfList (PointerToTheList  :  in  out  ListPointer; 

TheltemToBelnserted  :  in  Item)  is 

TempPointer  :  ListPointer; 

PointerToNewNodeToBelnserted  :  ListPointer; 
begin 

PointerToNewNodeToBelnserted  :=  new  ListNode; 
PointerToNewNodeToBelnserted. Data  :=  TheltemToBelnserted; 
if  IsEmpty (PointerToTheList)  then 

InsertAtHeadOfList (PointerToTheList , TheltemToBelnserted) ; 
else 

TempPointer  :=  PointerToTheList; 
while  TempPointer. NextPointer  /=  null 
loop 

TempPointer  :=  TempPointer . NextPointer ; 
end  loop; 

TempPointer . NextPointer  :=  PointerToNewNodeToBelnserted; 


end  if ; 

end  InsertAtTailOfList ; 

procedure  Insert InOrderlnList (PointerToTheList  :  in  out  ListPointer; 

TheltemToBelnserted  :  in  Item)  is 
Temp,  Tra*l  :  ListPointer  :=  PointerToTheList; 
PoinberToTheNewNodeToBelnserted  :  ListPointer; 
begin 

if  IsEmpty (PointerToTheList)  or  else 

(NOT*  LE (Key (PointerToTheList . Data) , Key (TheltemToBelnserted) ) )  the 
InsertAtHeadOf List ( PointerToTheList , TheltemToBelnserted) ; 
else 

while  (Temp  /=  null)  and  then 

(LE (Key (Temp. Data) , Key (TheltemToBelnserted) ) )  loop 
Trail  :=  Temp; 

Temp  :=  Temp. NextPointer; 
end  loop; 

PointerToTheNewNoceToBelnserted  :=  new  ListNode; 
PointerToTheNewNodeToBelnserted. Data  :=  TheltemToBelnserted; 

Trail .NextPo inter  :=  PointerToTheNewNodeToBelnserted ; 
PointerToTheNewNodeToBelnserted.NextPointer  :=  Temp; 
end  if; 

end  InsertlnOrderlnList ; 

procedure  RemoveFromHeadOfList (PointerToTheList  :  in  out  ListPointer; 

Removedltem  :  out  Item)  is 

Temp  :  ListPointer  :=  PointerToTheList; 
begin 

if  IsEmpty (PointerToTheList)  then 
raise  EmptvList; 
else 

Removedltem  ;=  PointerToTheList. Data; 

PointerToTheList  :=  PointerToTheList .NextPointer ; 

Dispos e (Temp) ; 
end  if; 

end  RemoveFromHeadOfList; 

procedure  RemoveFromTailOf List (PointerToTheList  :  in  out  ListPointer; 

Removedltem  :  out  Item)  is 

TempPointer,  PriorPc inter  :  ListPointer; 
begin 

if  IsEmpty (PointerToTheList)  then 
raise  EmptvList; 

elsif  PointerToTheList . NextPointer  =  null  then 

RemoveFromHeadOfList (PointerToTheList ,  Removedltem); 
else 

TempPointer  :=  PointerToTheList; 
while  TempPointer . NextPointer  /=  null 
loop 

PriorPointer  :=  TempPointer; 

TempPointer  ;=  TempPointer .NextPointer ; 
end  loop; 

Removedltem  :=  TempPointer . Data; 

Dispose (TempPointer) ; 

PriorPointer. NextPointer  :=  null; 
end  if; 

end  RemoveFromTailOf List ; 

procedure  RemoveByKeyFrcmList (PointerToTheList  :  in  out  ListPointer; 

Removedltem  :  out  Item; 


:  in  Key type)  is 


Key Value 

TempPointer,  PriorPointer  :  ListPo inter; 
begin 

if  IsEmpty (PointerToTheList)  then 
raise  EmptyList; 
elsif  EQ(Key (PointerToTheList. Data) , KeyValue)  then 

RemoveFromHeadOf List (PointerToTheList,  Removedltem) ; 
else 

TempPointer  :=  PointerToTheList; 
while  (TempPointer  /=  null)  and  then 

(NOT  EQ (Key (TempPointer . Data) ,KeyValue)) 

loop 

PriorPointer  :=  TempPointer; 

TempPointer  :=  TempPointer .NextPointer; 
end  loop; 

if  TempPointer  /=  null  then 

Removedltem  :=  TempPointer. Data; 

PriorPointer. NextPointer  ;=  TempPointer .NextPointer ; 

Dispose (TempPointer) ; 
else 

raise  EmptyList; 
end  if? 
end  if; 

end  Remove  By Key FromLi s t  ? 

function  AreEqual (PointerToLl ,  PointerToL2  :  ListPointer)  return  boolean 
TempPointerToLl  :  ListPointer  :=  PointerToLl? 

TempPointerToL2  :  ListPointer  :=  PointerToL2 ; 
begin 

while  (TempPointerToLl . Data  =  TempPointerToL2 . Data)  and 

(TempPointerToLl  /=  null)  and  (TempPointerToL2  /=  null) 

loop 

TempPointerToLl  :=  TempPointerToLl. NextPointer ; 

TempPointerToL2  :=  TempPointerToL2 .NextPointer ; 
end  loop; 

if  (TempPointerToLl  =  null)  and  (TempPointerToL2  =  null)  then 
return  true; 

elsif  (TempPointerToLl  =  null)  and  (TempPointerToL2  /=  null)  then 
return  false; 

elsif  (TempPointerToLl  /=  null)  and  (TempPointerToLl  =  null)  then 
return  false; 
else 

return  (TempPointerToLl . Data  =  TempPointerToL2 . Data) ; 
end  if; 
end  AreEqual ; 

function  LengthOf (PointerToL  :  ListPointer)  return  Count  is 
TempPointer  :  ListPointer  ;=  PointerToL; 

Length  :  Count  :=  0; 
begin 

while  TempPointer  /=  null 
loop 

Length  :=  Length  +  1; 

TempPointer  :=  TempPointer .NextPointer ? 
end  loop? 
return  Length ; 
end  LengthOf? 


end  Lists; 


with  Lists; 

package  Polynomials  is 

subtype  Coef f icientType  is  integer; 
subtype  ExponentType  is  integer; 

type  Term  is  record 

Coefficient  :  Coef f icientType ; 
Exponent  :  ExponentType ; 
end  record; 


function  ExponentValue (ATerm  :  Term)  return  ExponentType; 

function  LE (Exponentl ,  Exponent2  :  ExponentType)  return  boolean; 

function  EQ (Exponent 1 ,  Exponent2  ;  ExponentType)  return  boolean; 

package  PolynomialLists  is  new  Lists (Item=>Term, KeyType=>ExponentTvpe 

LE  =>  LE,  EQ  =>  EQ, 

Key  =>  ExponentValue) ; 

use  PolynomialLists; 

subtype  Polynomial  is  ListPointer; 

function  CreatePolynomial (InputFile  :  string)  return  Polynomial; 
function  "+"(P1,P2  ;  Polynomial)  return  Polynomial; 
procedure  Put(P  :  in  Polynomial) ; 


end  Polynomials; 


with  Text_IO;  use  Text_IO; 
package  body  Polynomials  is 

function  NoMoreTerms (P  :  Polynomial)  return  boolean  renames 
PolynomialLists . IsEmpty ; 

function  TermValue(P  :  Polynomial)  return  Term  renames 
PolynomialLists . GetData ; 

procedure  AddTermToPolynomial (P  :  in  out  Polynomial;  ATerm  :  in  Term) 
renames  PolynomialLists . InsertlnOrderlnList ; 

function  MoreTerms(P  :  Polynomial)  return  boolean  is 
begin 

return  NOT  (NoMoreTerms (P) ) ; 
end  MoreTerms; 

function  ExponentValue (ATerm  ;  Term)  return  ExponentType  is 
begin 

return  ATerm . Exponent ; 
end  ExponentValue; 

function  Coef f icientValue (ATerm  :  Term)  return  Coef f icientType  is 
begin 

return  ATerm. Coefficient ; 
end  Coef f icientValue ; 

function  LE (Exponentl ,  Exponent2  :  ExponentType)  return  boolean  is 
begin 

return  Exponentl  <=  Exponent2 ; 
end  LE; 

function  EQ (Exponentl ,  Exponent2  :  ExponentType)  return  boolean  is 
begin 

return  Exponentl  =  Exponent2 ; 
end  EQ; 

function  CreatePolynomial (InputFiie  :  string)  return  Polynomial  is 
ATerm  :  Term; 

PclvnomialFile  ;  file_type; 

P  :  Polynomial ; 

package  Int_IO  is  new  Integer_IO ( integer) ; 
use  Ir.t_IC; 
begin 

Open (PolynomialFile, In_File, InputFiie) ; 
while  NOT  end_of_f ile (PolynomialFile) 
loop 

Get (PolynomialFile, ATerm. Coefficient;  ; 

Get (PolynomialFile, ATerm. Exponent) ; 
if  ATerm. Coef ficient  /=  0  then 
AddTermToPolynomial (P, ATerm) ; 
end  i f ; 
end  loop; 
return  P; 
exception 

when  Name_Error=>Put_Line ("ERROR  -  Nonexistent  file"); 
when  Data_Error=>Put_Line ("ERROR  -  Data  error  in  file"); 
end  CreatePolynomial; 


function  "+"(P1,P2  :  Polynomial)  return  Polynomial  is 


Tempi  :  Polynomial  :=  PI; 

Temp2  :  Polynomial  ;=  P2 ; 

Sum  :  Polynomial ; 

Tail  :  Polynomial; 
begin 

if  IsEmpty(Fl)  then 
Copy (P2 , Sum) ; 
els if  IsEmpty(P2)  then 
Copy (PI, Sum) ; 
else 

while  (MoreTerms (Tempi)  and  MoreTerms (Temp2 ) ) 
loop 

while  (MoreTerms (Tempi)  and  MoreTerms (Temp2 ) )  and  then 

(Exponent Value (TermValue (Tempi) ) =ExponentValue (TermValue (Tempi ) 
loop 

if  (Coef f icientValue (TermValue (Tempi) )  + 

Coef f icientValue (TermValue (Temp2) ) )  /-  0  then 
AddTermToPolynomial (Sum, (Coef f icientValue (TermValue (Tempi) ) 

+Coeff icientValue (TermValue (Temp2 ) ) , 
ExponentValue (TermValue (Tempi) ) ) ) ; 

end  if; 

Tempi  :=  Successor (PI, Tempi) ; 

Temp2  :=  Successor ( P2 , Temp2 )  ; 
end  loop; 

while  (MoreTerms (Tempi)  and  MoreTerms (Temp2 ) )  and  then 

(ExponentValue (TermValue (Tempi) ) <ExponentValue (TermValue (Temp2 ) , 
loop 

AddTermToPolynomial (Sum, (Coef f icientValue (TermValue (Tempi) ) , 

ExponentValue (TermValue (Tempi) ) ) ) ; 
Tempi  :=  Successor (PI , Tempi) ; 
end  loop; 

while  (MoreTerms (Tempi)  and  MoreTerms (Temp2 ) )  and  then 

(ExponentValue (TermValue (Temp2 ) ) <ExponentValue (TermValue (Tempi; , 
loop 

AddTermToPolynomial  (Sum,  (Coef  f  icientValue  (TermValue  (Te;'p2  )  )  , 

ExponentValue (TermValue (Temp2) ) ) ) ; 
Temp2  ;=  Successor (P2 , ?emp2 } ; 
end  loop; 
end  loop; 
end  if; 

if  MoreTerms (Temp2 )  then 
Tempi  :=  Temp 2 ; 
end  ; f ; 

while  McreTerms (Tempi)  loop 

AddTermToPolynomial (Sum, (Coef f icientValue (TermValue (Tempi) ) , 

ExponentValue (TermValue (Tempi) ) ) ) ; 

Tempi  :=  Successor ( PI , Tempi) ; 
end  loop; 

return  Sum; 

end 

procedure  Put(P  :  in  Polynomial)  is 
Temp  :  Polynomial  :=  P; 

package  Int_IO  is  new  Integer_IO ( integer) ; 
use  Int_IO; 
begin 


while  MoreTerms (Temp)  loop 

if  Coef f icientValue (TermValue (Temp) )  >  0  then 
Put '  •+• ) ; 
end  if ; 

Put (Coef f icientValue (TermValue (Temp) )  ,  0)  ; 

Put ( "XA " ) ? 

Put (ExponentValue (TermValue (Temp) ) ,0)  ; 

Temp  :=  Successor (P, Temp) ; 
end  loop; 
end  Put; 

end  Polynomials; 


with  Polynomials,  Text_IO;  use  Polynomials,  Text_IO; 
procedure  AddPolynomials  is 

FirstPolynomial , SecondPolynomial  :  string (1 .. 30)  := 

II  I!  • 

» 


procedure  GetPolynomialFileName (FileName  :  out  string)  is 
NumChars  :  natural; 

TFileName  :  string ( 1 .. 30) ; 
begin 

New_Line (2) ; 

Put_Line ( "Enter  filename  where  a  polynomial  is  located."); 

Get_Line (TFileName, NumChars) ; 

FileName  ;=  TFilename (1 .. NumChars) ; 
end  GetPolynomialFileName; 

begin 

New_Page ; 

GetPolynomialFileName (FirstPolynomial) ; 

GetPolynomialFileName (SecondPolynomial ) ; 

Put (CreatePolynomial (FirstPolynomial)  +  createPolynomial (SecondPolynomial 
end  AddPolynomials; 


generic 

type  Item  is  private; 
type  Index  is  (<>) ; 

type  Items  is  array (Index  range  <>)  of  Item; 
with  function  "<"  (Left  :  in  Item; 

Right  :  in  Item)  return  Boolean; 

package  Heap_Sort  is 

procedure  Sort  (The_Items  :  in  out  Items) ; 
end  Heap_Sort; 


generic 

type  Item  is  private; 
type  Index  is  (<>) ; 

type  Items  is  array (Index  range  <>)  of  Item; 
with  function  "<"  (Left  :  in  Item; 

Right  :  in  Item)  return  Boolean; 

package  Quick_Sort  is 

procedure  Sort  (The_Items  :  in  out  Items)  ; 
end  Quick  Sort; 


generic 

type  Item  is  private; 
type  Index  is  (<>) ; 

type  Items  is  array (Index  range  <>)  of  Item; 
with  function  "<"  (Left  :  in  Item; 

Right  :  in  Item)  return  Boolean; 
package  Binary_Insertion_Sort  is 

procedure  Sort  (The_Items  :  in  out  Items) ; 

end  Binary_Insertion  Sort; 


[Taken  from  Software  Components  with  Ada  by  Grady  Booch] 


generic 

type  Key  is  limited  private; 
type  Item  is  limited  private; 
type  Index  is  (<>) ? 

type  Items  is  array (Index  range  <>)  of  Item; 
with  function  Is_Egual  (Left  :  in  Key; 

Right  r  in  Item)  return  Boolean; 

package  Sequential_Search  is 

function  Location_Of  (The_Key  :  in  Key; 

In_The_Items  ;  in  Items)  return  Index; 

Item_Not_Found  r  exception; 

end  Sequential_Search; 


generic 

type  Key  is  limited  private; 
type  Item  is  limited  private; 
type  Index  is  (<>)  ; 

type  Items  is  array (Index  range  <>)  of  Item; 
with  function  Is_Equal  (Left  :  in  Key; 

Right  :  in  Item)  return  Boolean; 
with  function  Is_Less_Than  (Left 

Right 

package  Oraered_Sequential_Search  is 


in  Key; 
in  Item)  return  Boolean; 


function  Location_Of  (The_Key 

In  The  Items 


in  Key; 

in  Items)  return  Index; 


Item_Not_Found  :  exception; 
end  Ordered  Sequential  Search; 


generic 

type  Key  is  limited  private; 
type  Iren  is  limited  private; 
type  Index  is  (<>) ; 

type  Items  is  array (Index  ranee  <>)  of  Item; 
with  function  Is.  Equal  (Left  in  Key; 

. ..  _  .  Right  ;  in  Item)  return  Boolean; 

W1~h  function  Is_Less_Than  (Left  :  in  Key; 

,  Right  :  in  Item)  return  Boolean; 

package  Binary'  Search  is 


function  Location_Of  (The_Kev 

In  The  Items 


in  Key; 

in  Items)  return  Index; 


Item_Not_Found  :  exception; 
nd  Binarv  Search; 


[Taken  from  Software  ComDonents  wi tn  Ada  by 
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task  [type]  [is 

{entry__declaration} 

{ representation_clause} 
end  [task  simple_name]  ] 


task  body  task_simple_nan»e  is 
[declarative_part] 
begin 

[ sequence_of_statements ] 
(exception  “ 

except ion_handler 
{ except ion_handler } ) 
end  [task  simple  name] ; 
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Simplest  Form  of  Task  Entry 


ACCEPT 

Task  T1  is 

entry  ENTRY1; 
end  Tl; 


Task  body  Tl  is 

BEGIN 

LOOP 


ACCEPT  ENTRY1  DO 
<$0S> 
end  ENTRY1; 

<S0S> 

END  LOOPJ 
END  Tlj 

“-WAIT  FOREVER  FOR  CALL  TO  ENTRY1 
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END  T 1 


Task  T1  is 

entry  ENTRY1; 
END  Tlj 


Task  body  T1  is 

BEGIN 

LOOP 


accept  ENTRY1;  --'sync'  call  only 

<sos> 


END  LOOP; 

END  Tlj 

--WAIT  FOREVER  FOR  CALL 


TO  ENTRY1 


--EVEN  IF  ENTRY1  HAS  PARAMETERS  ASSOCIATED  WITH 

IT,  THE  ACCEPT  BLOCK  DOES  NOT  HAWE  TO  HAVE  A 
SEQUENCE  OF  STATEMENTS 
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SELECT  Statement 


Used  by  the  task  to  allow  options 

Simplest  form  is  the  selective  wait  (wait  forever) 

Task  T1  is 

entry  ENTRYlj 
entry  ENTRY2; 

END  Tl; 


Task  body  Tl  is 
begin 
loop 

SELECT 

ACCEPT  ENTRY1  DO 

<sas> 

end  ENTRYlj 
<S0S> 

OR 

accept  ENTRY2  do 
<S0S> 

end  ENTRY2; 

<S0S> 

--AS  many  'or'  and  accept  clauses  as  needed 

END  SELECT; 

END  LOOP; 

END  T 1 ; 

— WAIT  FOR  EITHER  ENTRY1  OR  ENTRY2 
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Selective  wait  with  else  (don't  wait  at  all) 


Task  T1  is 

entry  ENTRY1; 
END  Tlj 


Task  body  T1  rs 

BEGIN 

LOOP 

SELECT 

ACCEPT  ENTRY1  DO 

<so$> 

END  ENTRY1; 

<S0S> 


SE 

S0S> 


END  SELECT; 
END  LOOP; 

END  Tl; 


IF  THERE  IS  NOT  A  CALLER  WAITING  RIGHT  NOW, 
DO  THE  ELSE  PART* 
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Selective  wait  with  else,  multiple 

ACCEPTS 

Task  T1  is 

entry  ENTRYlj 
entry  ENTRY2; 
end  Tl; 


Task  body  Tl  is 

BEGIN 

LOOP 

SELECT 

ACCEPT  ENT R Y 1  DO 

<sos> 

end  ENTRYlj 
<S0S> 

OR 

accept  ENTRY2  do 
•  •  • 

--  AS  MANY  'OR7  AND  'ACCEPT'  CLAUSES  AS  NEEDED 


ELSE 

<S0S>; 

END  SELECT; 
END  LOOP; 

END  Tlj 
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Select  with  delay  alternative 
(wait  a  finite  time) 


Task  body  T1  is 

BEGIN 

loop 

select 

ACCEPT  ENTRY1  DO**** 

[  OR 

accept  ENTRY2 . 1 

OR 

DELAY  15  •  0  J  —SECONDS 

<  SOS  >  j 

END  SELECT; 

END  LOOP; 

END  Tl; 

If  ENTRY1  called  within  15  seconds, 

THEN  YOU  ACCEPT  THE  CALL*  OTHERWISE, 
AFTER  15  SECONDS  YOU  WILL  DO  SOMETHING* 
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'DELAY'  Rules 


YOU  MAY  HAVE  SEVERAL  ALTERNATIVES 
WITH  A  DELAY  STATEMENT. 

Since  delays  can  be  static,  the  shortest 

DELAY  ALTERNATIVE  WILL  BE  SELECTED* 

Zero  and  negative  delays  are  Legal. 


You  MAY  NOT  HAVE  AN  ELSE  PART  WITH 
A  DELAY,  SINCE  THE  DELAY  WOULD  NEVER 
BE  ACCEPTED* 
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' DELAY'  Rules 

YOU  MAY  HAVE  SEVERAL  ALTERNATIVES 
WITH  A  DELAY  STATEMENT. 

Since  delays  can  be  static,  the  shortest 

DELAY  ALTERNATIVE  WILL  RE  SELECTED. 

Zero  and  negative  delays  are  Legal. 


You  MAY  NOT  HAVE  AN  ELSE  PART  WITH 
A  DELAY,  SINCE  THE  DELAY  WOULD  NEVER 
BE  ACCEPTED* 
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Select  with  delay  *lternative 
(wait  a  finite  time) 

Task  body  T1  is 

BEGIN 

LOOP 

SELECT 

ACCEPT  ENTRY1  DO-*** 

(or 

accept  ENTRY2 . ] 

OR 

DELAY  <EXPRESS I ON> ; 

<  SOS  > ; 

OR 

DELAY  <  EXPRESS  I ON> ; 

<S0S>; 

—  SHORTEST  DELAY  WILL  GET  CHOSEN 

END  SELECT; 

END  LOOP; 

END  Tl; 
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Guards  can  be  used  on  any  accept 

STATEMENT 


when  S0ME_C0ND I T I  ON  ®> 
accept  ENTRY1  . 


If  there  is  no  GUARD,  the  accept  statement 
IS  SAID  TO  BE  OPEN* 

If  there  is  a  GUARD,  and  the  WHEN  condition 
IS  TRUE,  THE  ACCEPT  IS  ALSO  OPEN. 

False  GUARD  statements  are  said  to  be  CLOSED. 

OPEN  alternatives  are  considered.  If  there  is 
more  than  one,  then  ONE  IS  SELECTED  ARBITRARILY. 

If  there  are  NO  OPEN  ALTERNATIVES  (and  no  else 
part),  the  exception  PRQGRAM_ERROR  is  raised. 
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TERMINATION 


When  a  task  has  completed  its  sequence 

OF  STATEMENTS,  ITS  STATUS  IS  COMPLETED 

Additionally,  there  is  an  option  that 

ALLOWS  A  TASK  TO  TERMINATE* 


SELECT 

ACCEPT  ENTRY1  DO  . 

[  OR 

accept  ENTRY2  do . ] 

OR 

TERMINATE; 

END  SELECT; 

This  may  not  be  used  with  either  the 
the  DELAY  or  an  ELSE  clause* 

Since  this  is  used  only  with  a  'wait  forever' 

TASK,  THIS  OPTION  ALLOWS  A  TASK  THAT  IS 
WAITING  FOREVER  TO  TERMINATE  IF  ITS  PARENT 

is  also  ready  TO  quit. 
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Might,  always  take  ENTRY  1  ! ! ! ! 


KILLING  A  TASK 
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PROBLEMS  WITH  PARALLELISM 
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task  SEMAPHORE  is 

ENTRY  P;  "GET  RESOURCE 
ENTRY  V;  --RELEASE 

end  SEMAPHORE; 

task  body  SEMAPHORE  is 

AVAILABLE  :  BOOLEAN  :=  TRUE; 

BEGIN 

LOOP 

SELECT 

WHEN  AVAILABLE 
ACCEPT  P  DO 

AVAILABLE  :=  FALSE; 

END  P; 

OR 

when  not  AVAILABLE 

ACCEPT  V  DO 

AVAILABLE  TRUE; 

END  V; 

OR 

TERMINATE; 

END  LOOP; 

end  SEMAPHORE ; 
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Task  Special  Ops  is 

entry  ASSIGN  (  Object  :  in  SomeJType  ); 
entry  RETRIEVE  (  Object  :  out  Some_Type); 
end  Special_Ops; 


Task  body  Special_Ops  is 
ThE_OBJECT  :  SoME_TYPE; 

BEGIN 

loop 

SELECT 

accept  ASS  I GN ( Ob j ect : in  Some_Type)do 
The  Object  :■  Object; 
end  ASSIGN; 

OR 

accept  RET  R I  EVE ( Object : out  Some_type)do 
Object  :*  The_Object; 
end  RETRIEVE; 

OR 

TERMINATE; 

END  SELECT; 

END  LOOP; 

END  SpECIAL_OpS; 
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CALLING  A  TASK  ENTRY 
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WAIT  AT 


CALL  AND  WAIT  FOREVER 

TO  CALL  AN  ENTRY,  SPECIFY  THE 
TASK  NAME  AND  THEN  THE  ENTRY  NAME 

BE6IN 

*  Tl-ENTRYl(DATA); 
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TIMED  ENTRY  CALL 

(wait  for  a  finite  time) 

SELECT 

Tl.ENTRYl(DATA); 

<S0S> 

OR 

DELAY  60; 

<sos> 

END  SELECT; 


YOU  CANNOT  USE  AN  'OR'  TO  CALL  TWO  (or  more) 
TASK  ENTRIES!!! 

This  would  be  equivalent  to  standing  in  two 

DIFFERENT  LINES  AT  ONCE* 
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CONDITIONAL  ENTRY  CALLS 

(don't  wait  at  all) 


SELECT 

Tl.ENTRYl(DATA); 

<S0S> 

ELSE 

<S0S> 

END  SELECT; 


Notice  the  'orthogonality'  or  the 
SELECT  STATEMENT.  IT  IS  USED  IN 
EITHER  a  TASK  ENTRY  CALL  OR  AN 
ACCEPT  STATEMENT* 


Also  notice  that  instead  of 
'accept. ..BEGIN.. .end  ACCEPT; 

IT  IS 

.  ' accept  ...  do- end  ENTRY_NAME; 
WHY??? 
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SYNCHRONIZATION  OF  DATA 


task  SYNC  is 

ENTRY  UPDATE  (  DATA  :  in  DATATYPE); 
entry  READ  (  DATA  :out  DATA_TYPE); 
end  SYNC; 

TASK  BODY  SYNC  IS 
LOCAL  :  DAT A_TYPE ; 

BEGIN 

LOOP 

SELECT 

accept  UPD ATE ( DAT  A  :  in  DAT  A_T  YPE )  do 
LOCAL  :»  DATA; 
end  UPDATE; 

OR 

terminate; 

END  SELECT; 

SELECT 

accept  READ  (DATA  :  out  DAT A_TYPE )  do 
DATA  :=  LOCAL; 
end  READ; 

OR 

terminate; 

END  SELECT; 

END  LOOP; 

END  SYNC; 
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FAMILIES  OF  ENTRIES 


type  URGENCY  is  (LOW,  MEDIUM,  HIGH); 
task  MESSAGE  is 

ENTRY  RECEI VE(URGENCY)  (DATA  :  DATATYPE); 
end  MESSAGE; 

task  body  MESSAGE  is 

BEGIN 

LOOP 

SELECT 

ACCEPT  RECEI VE( HIGH)  (DATA:  DATATYPE)  do 
end*RECEI VE; 

OR 

when  RECEIVE(HIGH)’ count  ■  0  s> 

accept  RECEIVE(MEDIUM)  ( DATA: DAT A_TYPE)  do 

end  RECEIVE; 

OR 

when  RECEI VE( HI GH ) ' count+RECEI VE( MEDI UM ) ' count -0 
accept  RECE I VE ( LOW )  ( DATA :  DATATYPE )  do 

end*  RECEI VE; 
or 

DELAY  1.0;  —  SHORT  wait 

end  MESSAGE; 
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Same  thing,,  with  no  guards 


type  URGENCY  is  ( LOW,  MEDIUM,  HIGH) j 


task  MESSA6E  is 

entry  RECEIVE( URGENCY)  (DATA  :  DATATYPE); 
END  MESSAGE; 


task  body  MESSAGE  is 
begin 

LOOP 

SELECT 

accept  RECEIVE(HIGH)  (DATA: DATA  TYPE)  do 


end  RECEIVE; 

ELSE 

SELECT 

accept  RECEIVE(MEDIUM)  (DATA: DATA  TYPE)  do 


end  RECEIVE; 

ELSE 

SELECT 

ACCEPT  RECEI VE( LOW)  (DATA : DATA  TYPE)  do 


end  RECEIVE; 
or 


DELAY  1.0;  — 
END  SELECT; 

END  SELECT; 

END  SELECT; 

end  MESSAGE; 


SHORT  WAIT 


i 
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REPRESENTATION  SPECIFICATIONS 


Length  Clause 


T'  STORAGES  I ZE 

TASK  TYPE  T1  IS 
ENTRY  ENTRY  1; 

FOR  Tl' STORAGE  SIZE  use 

2000#SYSTEM. STORAGE  JJN IT); 

END  Tlj 

The  prefix  T  denotes  a  task  type. 

The  simple  expression  may  be  static,  and  is  used 

TO  SPECIFY  THE  NUMBER  OS  STORAGE  UNITS  TO  BE 
RESERVED  OR  FOR  EACH  ACTIVATION  (NOT  THE  CODE)  OF 
THE  TASK. 
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Address  Clause 


TASK  TYPE  T1  IS 

ENTRY  ENTRY_1 ; 

FOR  Tl  USE  AT  16#167A#j 
END  Tl; 

In  this  case,  the  address  specifies  the  actual 

LOCATION  IN  MEMORY  WHERE  THE  MACHINE  CODE 
ASSOCIATED  WITH  Tl  WILL  BE  PLACED* 


TASK  Tl  IS 

entry  ENTRY_1; 
for  ENTR Y_1  use  at  16 
END  Tl; 


If  this  CASE/  ENTRY_1  will  be  mapped  to  hardware 
interrupt  6A* 

Only  in  parameters  can  be  associated  with 
interrupt  entries- 

An  interrupt  will  act  as  an  entry  call  issued  by 

THE  HARDWARE/  WITH  A  PRIORITY  HIGHER  THAN  ANY 
USER-DEFINED  TASK* 

Depending  upon  the  implementation/  there  can  be 
many  restrictions  upon  the  type  of  call  to  the 

INTERRUPT,  AND  UPON  THE  TERMINATE  ALTERNATIVES- 


NOTE:  you  can  directly  call  an  interrupt  entry. 
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TASKS  AT  DIFFERENT  PRIORITIES 


Given  5  tasks,  3  of  varying  priority,  1  to  be  interrupt 

DRIVEN,  AND  1  THAT  WILL  BE  TIED  TO  THE  CLOCK. 

procedure  HEAVY_STUFF  is 
TASK  H I GH_PR I  OR  I T Y  is 

PRAGMA  PRIORITY{50);  "'OR  AS  HIGH  AS  SYSTEM  ALLOWS 
ENTRY  POINT; 

END  H I GH_PR I  OR  I TY ; 

task  MEDIUM_PRIORITY  is 
PRAGMA  priority(25)  ; 

ENTRY  POINT; 

END  MED  I UM_PR I  OR  I TY ; 

task  L0W_P  R I  OR  I T Y  is 

PRAGMA  PR  I  OR  I TY ( 1  )  ; 

ENTRY  POINT; 

END  LOW _ P R I  OR  I TY; 

task  INTERRUPT  DRIVEN  is 
ENTRY  POlfiT; 

FOR  POINT  USE  AT  16#61# ;  --interrupt  97 
END  INTERRUPT.DRIVEN; 

■  task  C10CK_DR I VEN  i s 

--THERE  ARE  TWO  WAYS  TO  DO  THIS 

--First  way  is  to  have  another  task  monitor 
--  the  clock,  and  call  C10CK_DR I VEN . CALL 
--  every  time  unit. 

ENTRY  CALL; 

--Second  way  is  to  actually  tie  CALL  to  an 
--  clock  interrupt,  and  let  CALL  determine  when 

--  HE  WISHES  TO  PERFORM  AN  ACTION 

for  CALL  use  at  16#32#;  --assume  interrupt  50 

--  IS  A  CLOCK  INTERRUPT 

end  CLOCK  DRIVEN; 
end  HEAVY_STUFF; 
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task  QUEUE  is 

entry  INSERHDATA  :  in  DATA  TYPE); 

ENTRY  REMOVE ( DATA  :out  DATATYPE); 
end  QUEUE; 

TASK  BODY  QUEUE  IS 

HEAD, TAIL  :  INTEGER  :=  0; 

Q  :  array  (1..100)  of  DATATYPE; 

BEGIN 

LOOP 

SELECT 

when  TAIL  -  HEAD  +  1  /=  0  and  then 
TAIL  -  HEAD  +  1  /=  100  => 
accept  INSERT ( DATA  :  in  DATATYPE)  do 
if  HEAD  a  0  then  HEAD  :■  1;  end  if; 
if  TAIL  =  100  then  TAIL  ;=  0;  end  if; 
TAIL  :«  TAIL  +  1; 

Q(TAIL)  :«  DATA; 
end  INSERT; 

OR 

when  HEAD  /-  0  => 

accept  REMOVE! DATA  :out  DATATYPE)  do 
DATA  :=  Q( HEAD); 
if  HEAD  =  TAIL  then 
HEAD  :=  0; 

TAIL  :=  0; 

ELSE 

HEAD  HEAD  +  1; 

IF  HEAD  >  100  then  HEAD  :*  1;  end  if; 

END  IF; 

END  REMOVE; 

OR 

TERMINATE; 

END  SELECT; 

END  LOOP; 

END  QUEUE; 


TASK  TYPE  QUEUE  IS 

ENTRY  INSERKDATA  :  in  DATATYPE); 
ENTRY  REM0VE(DATA  :out  DATATYPE); 
end  QUEUE; 


TASK  BODY  QUEUE  IS 

HEAD, TAIL  :  INTEGER  :  = 
Q  :  array  ( 1 • - 100 )  OF 


1  0; 

DATATYPE; 


BE6IN 

LOOP 

SELECT 

WHEN  TAIL  -  HEAD  +  1  /*  0  and  then 
TAIL  -  HEAD  +  1  /=  100  => 
accept  INSERT(DATA  ;  in  DATATYPE)  do 
if  HEAD  *  0  then  HEAD  :*  1;  end  I 
if  TAIL  =  100  then  TAIL  :=  0;  end 
TAIL  TAIL  +  1; 

Q(TAIL)  :=  DATA; 
end  INSERT; 

OR 

when  HEAD  /*  0  => 

accept  REMOVE  C  DAT  A  :oijt  DAT  A_T  YPE )  do 
DATA  :«  Q( HEAD ) ; 
if  HEAD  =  TAIL  then 
HEAD  :=  0; 

TAIL  0; 


ELSE 

HEAD  :»  HEAD  +  1; 

if  HEAD  >  100  then  HEAD  :=  1; 


END  IF; 

end  REMOVE; 


OR 


TERMINATE; 
END  SELECT; 
END  LOOP; 

END  QUEUE; 


MY_QUEUE ,  YOU R_QUEUE  :  QUEUE;  —  two  tasks 


f; 

IF; 


END  IF; 
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GENERIC 

DATA  TYPE  :  private; 

QUEUE_SI ZE:  POSITIVE  100; 

package  QUEUE_PACK  is 

task  QUEUE  is 

entry  INSERT ( DATA  :  in  DATATYPE); 
entry  REMOVE ( DAT A  :out  DAT A_T YPE ) ; 
end  QUEUE; 

PACKAGE  BODY  QU£UE_PACK  IS 
task  body  QUEUE  is 

HEAD, TAIL  :  INTEGER  :=  0; 

Q  :  array  ( 1  •  •  QUEUE _ S I  ZE )  of  DATATYPE; 

BEGIN 

LOOP 

SELECT 

when  TAIL  -  HEAD  +  1  /*  0  and  then 
TAIL  -  HEAD  +  1  /»  QUEUE  SIZE  -> 

ACCEPT  INSERT  (DATA  :  in  DATATYPE)  do 
if  HEAD  *  0  then  HEAD  :=  1;  end  if; 
if  TAIL  *  QUEUE  SIZE  then  TAIL  :=  0;  end  if 
TAIL  :=  TAIL  +  T; 

Q(TAIL)  :=  DATA; 
end  INSERT; 
or 

when  HEAD  /=  0  *> 

accept  REMOVE ( DAT  A  :out  DATA  TYPE)  do 
DATA  :=  Q ( HEAD ) ; 
if  HEAD  *  TAIL  then 
HEAD  j«  0; 

TAIL  :=  0; 

ELSE 

HEAD  :=  HEAD  +  1; 

if  HE A D >  QUEUE_S I ZE  then  HEAD  :=  1;  end 

END  IF; 

END  REMOVE; 

OR 

TERM  I  NATE; 

END  SELECT; 

END  LOOP; 

END  QUEUE; 


package  NEW_QUEUE  IS  NEW  QU EUE_PAC K ( MY  RECORD,  250); 
package  0LD_QUEUE  is  new  QUEUE_PACK( INTEGER); 
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procedure  INSERT  INTEGER  (DATA  :  in  INTEGER 
0LD_QUEUE* INSERT; 

procedure  REMOVE  INTEGER  (DATA  :out  INTE6ER 
OLD_QUEUE. REMOVE; 


RENAMES 

RENAMES 
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procedure  SPIN  (R  :  RESOURCE)  is 

BEGIN 

LOOP 

SELECT 

R. SEIZE; 

return; 

ELSE 

NULL;  -’BUSY  WAITING 
END  SELECT; 

END  LOOP; 

END; 

— OR— 

procedure  SPIN  (R  :  RESOURCE)  is 

BEGIN 

R. SEIZE; 

return; 

END; 
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delay  15.0  *  MINUTES; 
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Task  Body  SPOOLER  is 
begin 

loop 
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end  SPOOLER 


SPOOLER. PRINTER_RE AD Y> 

accept  PRINT_FILE  (NAME  >  in  STRING)  do 


Kith  PRINTER.PflCKAGE; 
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IN-CLASS  EXERCISE 


Let  us  design  the  task  specifications  for  the  following 

SENAR I  0 • 


Three  tasks  have  acces  to  a  type  known  as  MESS AG£_T YPE • 
TASK_1  produces  messages*  TA$K_2  can  receive  messages, 

HOLD  THEM  IN  A  BUFFER  ( I F  NECESSARY),  AND  SENDS  THEM  TO 
TASK_3  WHEN  THE  DATE/TIME  FIELD  (PART  OF  MESSA6E_TYPE ) 
SAYS  TO* 


TASK  TASK_1  IS 


END  TASK_lj 


task  TASK_2  is 


end  TASK_2; 


task  TASK  3  is 


end  TASK_3; 
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Tasking  Exercise 


Write  a  main  program  and  two  tasks  to  simulate  a  house  alarm 
system.  The  main  program  is  an  input  simulator  to  the 
tasks.  One  task  keeps  track  of  the  status  of  the  house- 
Another  is  the  actual  alarm  system. 


Task  Is  The  House  Status  (Task  Name  : HOUSE ) 

Three  Entries  *>  OK,  N0T_0K,  WRITE 

The  entries  OK  and  N0T_0K  set  or  reset  a  flag  that 
determines  the  status  of  the  house.  NOOK  will  also  set  a 

VARIABLE  TO  TELL  YOU  WHICH  ALARM  IS  CURRENTLY  GOING  OFF. 

Both  OK  and  N0T_0K  should  print  out  a  message  verifying  that 
they  were  called.  The  WRITE  entry  will  print  the  status  of 
the  house.  If  there  is  an  alarm  currently  going  off,  WRITE 

WILL  TELL  YOU  THE  ALARM  NUMBER. 


Task  2:  The  Alarm  System  (Task  name:  ALARM)  . 

Three  Entries  =>  FIRE,  INTRUDER,  SHUTOFF 

The  Alarm  System  will  accept  any  of  the  three  entry 

CALLS  FROM  THE  INPUT  SIMULATOR.  If  THERE  ARE  NO  ENTRY  CALLS 
WITHIN  5  SECONDS,  IT  WILL  CALL  HOUSE -WRITE  TO  DISPLAY  THE 
STATUS.  FIRE  AND  INTRUDER  EACH  HAVE  a  PARAMETER  INDICATION 
THE  ALARM  LOCATION.  FIRE  LOCATIONS  ARE  '1'  THRU  '9'* 

INTRUDER  locations  are  'A'  thru  ' Z '  •  FIRE  and  INTRUDER 
SHOULD  CALL  HOUSE- NO T_0 K  (and  tell  the  house  where  the  alarm 

IS  SOUNDING),  AND  THEN  PRINT  OUT  A  MESSAGE 


Main  Program 

The  MAIN  program  will  read  in  characters  from  the 
KEYBOARD.  If  THE  CHARACTER  IS  A  '1'  THRU  '9',  CALL  THE  FIRE 
alarm.  If  the  character  is  a  'A'  thru  ' l'  then  it  calls  the 
intruder  alarm.  If  the  character  is  a  'O'(zero),  the  house 

IS  RESET  TO  OK-  If  THE  CHARACTER  IS  A  '!',  THEN  THE  ALARM 
IS  SHUTDOWN,  AND  THE  PROGRAM  ENDS.  ALL  OTHER  CHARACTERS  DO 
NOTHING- 


The  house  status  should  be  OK  to  start. 
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run  cookie 


The  house  is  ok 


The  house  is  ok 
& 

Invalid  character.  Try  again 

The  house  is  ok 
G 

House  alarm  set  to  not  OK  at  location  G 
Intruder  in  room  G 

The  house  is  not  ok  ..alarm  is  off  at  location  G 


The  house  is  not  ok  ..alarm  is  off  at  location  G 
4 

House  alarm  set  to  not  OK  at  location  4 
Fire  Alarm  t  4  has  been  set  off. 

The  house  is  not  ok  ..alarm  is  off  at  location  4 
0 

House  alarm  reset  to  OK. 

The  house  is  ok 


The  house  is  ok 

t 

The  alarm  has  been  turned  off 

•) 


8! 


wi.h  TEXT  10; 
use  TEXT_T0; 


PROCEDURE  COOKIE  IS 

CHAR  :  CHARACTER; 

TASK  HOUSE  IS 
ENTRY  OK; 

ENTRY  NOT  OK  (WHERE:CHARACTER); 

ENTRY  WRITE; 

END  HOUSE  ; 

task  ALARM  is  „  „ 

ENTRY  FIRE  (LOCATION: CHARACTER); 
ENTRY  INTRUDER  (LOCATION: CHARACTER); 
entry  SHUTOFF; 

END  ALARM  ; 
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TASK  BODY  HOUSE  IS 

TYPE  CONDITION  is  (OK,  N0T_0K); 
ALARM  STATUS  :  CONDITION  :•  OK; 
ALARM  LOCATION  :  CHARACTER; 


BEGIN 

LOOP 


SELECT 

ACCEPT  OK  DO 

ALARM  STATUS  :«  OK; 

PUT_LlNE( 'House  alarm  reset  to  OK.'); 
end  OK; 
or 

accept  NOT  OK  ( WHERE :CHARACTER)  do 
ALARM  STATUS  :«  NOT  OK; 

ALARM- LOC  AT  I  ON  WTTERE ; 

put  LlNE( 'House  alarm  set  to  not  OK  at's 

m _ _ _ _  «  a  a  i  unu  i  nr  at  i  Ail  \ 


LOCATION 

end  N0T_0K; 


&  ALARM_L0CATI0N); 


accept  WRITE  do 
NEW  LINE; 

case  ALARM_STATUS  is 
when  OK  *>PUT_LINE('The  house  is  ok"); 
wVien  N0TJ)K  =>  PUTJ.INE 

('The  house  is  not  ok"& 

'  ..ALARM  IS  OFF  AT  LOCATION  '  & 

ALARM_LOCAT ION ) ; 

END  CASE; 

NEW  LINE; 
end  WRITE; 


TERMINATE; 
END  SELECT; 

END  loop; 

HOUSE  ; 
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TASK  BODY  ALARM  IS 
BEGIN 

LOOP 


SELECT 

accept  FIRE  (LOCATION: CHARACTER)  do 
HOUSE. N0T_0K( LOCATION  ); 

PUT  ("Fire  Alarm  k  "); 

PUT  (LOCATION); 

PUt  LINE  ("  HAS  BEEN  SET  OFF.-); 
END  FIRE; 


OR 


OR 


ACCEPT  INTRUDER  ( LOCAT I  ON : CHARACTER )  do 
HOUSE. NOTJ)K(LOCATION); 

PUT  ("Intruder  in  room  -); 

PUT  (LOCATION); 

NEW  LINE; 

END  INTRUDER; 


accept  SHUTOFF; 

PUT_LINE  ("The  alarm  has  been  turned  off"); 
exit; 


or 


delay  5.0; 
HOUSE. WRITE; 


end  select; 
end  loop; 
end  ALARM; 
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BEGIN  —MAIN 

LOOP 

GET  (CHAR); 
SKIPJ.INE; 


case  CHAR 

WHEN 

IS 

•v  .. 

'9' 

■> 

WHEN 

'  A'  •  • 

'z' 

-> 

WHEN 

'A'  .. 

•v 

-> 

WHEN 

'O' 

*> 

WHEN 

*  i ' 

• 

»> 

WHEN 

OTHERS 

■> 

('Invalid 


ALARM. FIRE  (CHAR); 

ALARM. INTRUDER  (CHAR); 
ALARM. INTRUDER  (CHAR); 
HOUSE. OK; 

ALARM. SHUTOFF; 

PUTJ.INE 

CHARACTER-  TRY  AGAIN*); 


END  case; 

EXIT  WHEN  CHAR 
END  LOOP; 


end  COOKIE; 
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>  Overview 


Naming  an  exception 
Creating  an  exception  handler 


Raising  an  exception 


Handling  exceptions 


Turning  off  exception  checking 
Tasking  exceptions 


More  examples 


Summary 


What  is  an  exception 


Ada  exceptions 

Comparison 

-  the  American  way 

-  using  exceptions 


4 


A  run  time  error 


An  unusual  or  unexpected  condition 


A  condition  requiring  special  attention 
Other  than  normal  processing 

An  important  feature  for  debugging 

A  critical  feature  for  operational  software 


An  exception  has  a  name 


-  may  be  predefined 

-  may  be  declared 

The  exception  is  raised 

-  may  be  raised  implicitly  by  run  time  system 

-  may  be  raised  explicitly  by  raise  statement 

The  exception  is  handled 

-  exception  handler  may  be  placed  in  any  frame* 

-  exception  propagates  until  handier  is  found 

-  if  no  handler  anywhere,  process  aborts 


executable  part  surrounded  by  begin  -  end 


Tte  American  Way 


package  Stack_Package  is 

type  Stack_Type  is  limited  private; 

procedure  Push  (Stack  ;  in  c 

Element  :  in 

Overflow_Flag  :  out 


end  Stack_Package; 


with  TEXTJO; 

with  Stack_Package;  use  Stack_Package; 
procedure  Flag_Waving  is 

Stack  :  Stack_Type; 

Element :  Element_Type; 

Flag  :  BOOLEAN; 

begin 


Push  (Stack,  Element,  Flag); 
if  Flag  then 

TEXTJO. PUT  ("Stack  overflow"); 


end  if; 

•  •• 

end  Flag_Waving; 


Stack_Type; 

Element_Type 

BOOLEAN); 
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package  Stack_Package  is 

type  Stack_Type  is  limited  private; 

StackJDverflow, 

Stack_Underflow :  exception; 

procedure  Push  (Stack  :  in  out  Stack_Type; 

Element  :  in  Element_Type); 

-  may  raise  Stack_Overflow 

end  Stack_Package; 


with  TEXT  JO; 

with  Stack_Package;  use  Stack_Package; 
procedure  More_Natural  is 

■  as 

Stack  :  Stack_Type; 

Element :  Element_Type; 

begin 

a  aa 

Push  (Stack,  Element); 

a  aa 

exception 

when  Stack_Overflow  => 

TEXT_IO.PUT  ("Stack  overflow"); 

a  aa 

end  MoreJMatural; 


Overview 


>  Naming  an  exception 

Creating  an  exception  handler 

Raising  an  exception 

Handling  exceptions 

Turning  off  exception  checking 

Tasking  exceptions 

More  examples 

Summary 
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Predefined  exceptions 
Declaring  exceptions 


I/O  exceptions 


In  package  STANDARD  (also  see  chap  1 1  of  LRM) 
CONSTRAINT_ERROR 

violation  of  range,  index,  or  discriminant  constraint... 

NUMERIC_ERROR 

execution  of  a  predefined  numeric  operation  cannot 
deliver  a  correct  result 

PROGRAM_ERROR 

attempt  to  access  a  program  unit  which  has  not  yet 
been  elaborated... 

STORAGE_ERROR 

storage  allocation  is  exceeded... 

TASKING_ERROR 

exception  arising  during  intertask  communication 


exception_declaration  identifier Jist :  exception; 


•  Exception  may  be  declared  anywhere  an  object  declaration 
is  appropriate 


•  However,  exception  is  not  an  object 

-  may  not  be  used  as  subprogram  parameter,  record 

or  array  component 

-  has  same  scope  as  an  object,  but  its  effect  may 

extend  beyond  its  scope 


Example: 


procedure  Calculation  is 

Singular  :  exception; 

Overflow,  Underflow  .-exception; 


begin 

end  Calculation; 
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•  Exceptions  relating  to  file  processing 

•  In  predefined  library  unit  I0_EXCEPT10NS 

(also  see  chap  14  of  LRM) 

•  TEXTJO,  DIRECT  JO,  and  SEQUENTIAL  JO  with  it 


package  IO_EXCEPTIONS  is 


NAMEJERROR  :  exception; 
USEJERROR  :  exception; 

STATUSJERROR  :  exception; 
MODEJERROR  :  exception; 
DEVICEJERROR  :  exception; 
END_ERROR  :  exception; 

DATA_ERROR  :  exception; 

LAYOUTJERROR  :  exception; 


-attempt  to  use 
-invalid  operation 


-attempt  to  read 
-beyond  end  of  file 
-attempt  to  input 
-wrong  type 
-for  text  procf  ssing 


end  IO_EXCEPTIONS; 
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Oyilcnis 


Overview 


Naming  an  exception 
>  Creating  an  exception  handler 

Raising  an  exception 

Handling  exceptions 

Turning  off  exception  checking 

Tasking  exceptions 

More  examples 

Summary 
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Defining  an  exception  handier 

Restrictions 


Handler  example 


•  Exception  condition  is  "caught"  and  "handled"  by  an  exception 
handler 


•  Exception  handler  may  appear  at  the  end  of  any  frame  (block, 
subprogram,  package  or  task  body) 


begin 

exception 

--  exception  handler(s) 
end; 


*  Form  similar  to  case  statement 


exception_handler  ::= 

when  exception_choice  {(  exception_choice}  => 
sequence__of_statements 

exception_choice  ::=  exception_name  |  others 
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Restrictions 


Exception  handlers  must  be  at  the  end  of  a  frame 


Nothing  but  exception  handlers  may  lie  between  exception 
and  end  of  frame 


A  handler  may  name  any  visible  exception  declared  or 
predefined 


A  handler  includes  a  sequence  of  statements 
-  response  to  exception  condition 


A  handler  for  others  may  be  used 

-  must  be  the  last  handler  in  the  frame 

-  handles  all  exceptions  not  listed  in  previous 

handlers  of  the  frame 

(including  those  not  in  scope  of  visibility) 

-  can  be  the  only  handler  in  the  frame 
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procedure  Whatever  is 

Problem_Condition  :  exception; 

begin 

exception 

when  Problem_Condition  => 
Fixjt; 

when  CONSTRAiNT_ERROR  = 
Reportjt; 

when  others  => 

Punt; 


end  Whatever; 


Overview 


Naming  an  exception 


Creating  an  exception  handler 


>  Raising  an  exception 

Handling  exceptions 
Turning  off  exception  checking 
Tasking  exceptions 

More  examples 


Summary 


Elaboration  and  execution  exceptions 
How  exceptions  are  raised 
Effects  of  raising  an  exception 
Raising  example 
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Elaboration  exceptions  occur  when  declarations  are  being 
elaborated 

-  after  a  unit  is  "called" 

-  before  execution  of  the  unit  begins 

-  can  only  be  predefined  exceptions 

Execution  exceptions  occur  during  execution  of  a  frame 


Elaboration  exceptions  can  also  be  considered  as  execution 
exceptions 

-  depending  on  viewpoint 

-  can  consider  as  part  of  the  execution  of  the  last 
executable  statement  making  the  call  to  the  unit 
being  elaborated 

-  this  helps  with  understanding  the  consistency  of 
the  rules  for  exception  handling 
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H©w  Ero^ptteins  am  RaSsa^l 

Implicitly  by  run  time  system 

-  predefined  exceptions 

Explicitly  by  raise  statement 
raise_statement raise  [exception__name]; 

-  the  name  of  the  exception  must  be  visibie  at  the 

point  of  the  raise  statement 

-  a  raise  statement  without  an  exception  name  is 

allowed  only  within  an  exception  handler 


(1)  Control  transfers  to  exception  handler  at  end  of  frame 

being  executed  (if  handler  exists) 

(2)  Exception  is  lowered 

(3)  Sequence  of  statements  in  exception  hander  is  executed 

(4)  Control  passes  to  end  of  frame 

•  If  frame  does  not  contain  an  appropriate  exception  handler, 
the  exception  is  propagated  -  effectively  skipping  steps 
1  thru  3  and  going  straight  to  step  4 
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procedure  Whatever  is 

Problem_Condition  :  exception; 

Real_Bad_Condition  ;  exception; 

begin 


if  Problem_Arises  then 

raise  Probiem_Condition;  -  1 

end  if; 

if  Serious_Problem  then 

raise  Real_Bad_Condition;  -- 1 


end  if; 
exception 

when  Problem_Condition  =>  --  2 

Fix _ It;  -  3 

when  CONSTRAINT_ERROR  =>  -  2 

Reportjt;  --  3 

when  others  =>  --  2 

Punt;  -  3 

end  Whatever;  -  4 
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Overview 


Naming  an  exception 
Creating  an  exception  handler 

Raising  an  exception 

>  Handling  exceptions 

Turning  off  exception  checking 


Tasking  exceptions 


More  examples 


Summary 
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Handing  Excsptemi 

I 

I 

How  exception  handling  can  be  useful 

Which  exception  handler  is  used  j 

Sequence  of  statements  in  exception  handler 

I 

Propagation  | 

Propagation  example 
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H©w  E»®pi®n  Haimdltag  Car}  IE®  UssJiuil 

•  Normal  processing  could  continue  if 

-  cause  of  exception  condition  can  be  "repaired" 

-  alternative  approach  can  be  used 

-  operation  can  be  retried 

•  Degraded  processing  could  be  better  than  termination 

-  for  example,  safety-critical  systems 

•  If  termination  is  necessary,  "clean-up"  can  be  done  first 
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When  exception  is  raised,  system  looks  for  an  exception 
handler  at  the  end  of  the  frame  being  executed 

If  exception  is  raised  during  elaboration  of  the  declarative 
part  of  a  unit  (unit  is  not  yet  ready  to  execute) 

-  elaboration  is  abandoned  and  control  goes  to  the 

end  of  the  unit  with  the  exception  still  raised 

-  exception  part  of  the  unit  is  not  searched  for  an 

appropriate  handler 

-  effectively,  the  calling  unit  will  be  searched  for  an 

appropriate  handler 

--  consistent  with  execution  viewpoint 

-  if  elaboration  of  library  unit,  program  execution  is 

abandoned 

--  all  library  units  are  elaborated  with  the 
main  program 

If  exception  is  raised  in  exception  handler 

-  handler  may  contain  block(s)  with  handler(s) 

-  if  not  handled  locally  within  handler,  control  goes 

to  end  of  frame  with  exception  raised 


Handler  completes  the  execution  of  the  frame 

-  handler  for  a  function  should  usually  contain  a 
return  statement 


Statements  can  be  of  arbitrary  complexity 

-  can  use  most  any  language  construct  that  makes 

sense  in  that  context 

-  cannot  use  goto  statement  to  transfer  into  a 

handler 

-  if  handler  is  in  a  block  inside  a  loop,  could  use  exit 

statement 


Handler  at  end  of  package  body  applies  only  to  package 
initialization 


Occurs  if  no  handler  exists  in  frame  where  execution 
exception  is  raised 


Always  occurs  if  elaboration  exception  is  raised 
Also  occurs  if  raise  statement  is  used  in  handler 

Exception  is  propagated  dynamically 

-  propagates  from  subprogram  to  unit  calling  it 

(not  necessarily  unit  containing  its  declaration) 

-  this  can  result  in  propagation  outside  its  scope 

-  task  propagation  follows  same  principle,  but  a 

little  more  complicated 

Propagation  continues  until 

-  an  appropriate  handler  is  found 

-  exception  propagates  to  main  program  (still  with 

no  handler)  and  program  execution  is  abandoned 


procedure  Do_Nothing  is 


procedure  Hasjt  is 

Some_Problem  :  exception; 

begin 


raise  Some_Problem; 
exception 

when  Some_Problem  => 
Clean_Up; 
raise; 

end  Hasjt; 


procedure  Callsjt  is 
begin 


Hasjt; 
end  Callsjt; 


begin  --  DoJNothing 
Callsjt; 
exception 

when  others  =>  Fix_Everything; 
end  DoJMothing; 


Overview 


Naming  an  exception 
Creating  an  exception  handler 


Raising  an  exception 
Handling  exceptions 
>  Turning  off  exception  checking 


Tasking  exceptions 


More  examples 


Summary 
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Overhead  vs  efficiency 


Pragma  SUPPRESS 

Check  identifiers 
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©v<air!h®ii(dl  vs  Efffficiteinicy 


Exception  checking  imposes  run  time  overhead 

-  interactive  applications  will  never  notice 

-  real-time  applications  have  legitimate  concerns 

but  must  not  sacrifice  system  safety 

When  efficiency  counts 

-  first,  make  program  work  (using  good  design) 

-  be  sure  possible  problems  are  covered  by  exception 

handlers 

-  check  if  efficient  enough  -  stop  if  it  is 

-  if  not,  study  execution  profile 

~  eliminate  bottlenecks 
--  improve  algorithm 

-  avoid  "cute"  tricks 

-  check  if  efficient  enough  -  stop  if  it  is 

-  if  not,  trade-offs  may  be  necessary 

-  some  exception  checks  may  be  expendable  since 

debugging  is  done 

-  however,  every  suppressed  check  poses  new 

possibilities  for  problems 

--  must  re-examine  possible  problems 
--  must  re-examine  exception  handlers 

-  always  keep  in  mind 

--  problems  will  happen 

-  critical  applications  must  be  able  to 

deal  with  these  problems 
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Improving  the  design  is  far  better  -  and  easier  in 
the  long  run  -  than  suppressing  checks 
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•  Only  allowed  immediately  within  a  declarative  part  or 
immediately  within  a  package  specification 


pragma  SUPPRESS  (identifier  [,[  ON  =>]  name]); 


-  identifier  is  that  of  the  check  to  be  omitted 

(next  slide  lists  identifiers) 

-  name  is  that  of  an  object,  type,  or  unit  for  which 

the  check  is  to  be  suppressed 

--  if  no  name  is  given,  it  applies  to  the 
remaining  declarative  region 


•  An  implementation  is  free  to  ignore  the  suppress  directive 
for  any  check  which  may  be  impossible  or  too  costly  to 
suppress 


Example: 

pragma  SUPPRESS  (INDEX_CHECK,  ON  =>  Index); 
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These  identifiers  are  explained  in  more  detail  in  chap  1 1  of 
the  LRM 


Check  identifiers  for  suppression  of  CONSTRAINT_ERROR 
checks 


ACCESS_CHECK 

DISCRIM1NANTCHECK 

INDEX_CHECK 

LENGTHjCHECK 

RANGE_CHECK 


Check  identifiers  for  suppression  of  NUMERIC_ERROR  checks 

DIVISION_CHECK 

OVERFLOW_CHECK 

Check  identifier  for  suppression  of  PROGRAM_ERROR  checks 
ELABORATION_CHECK 

Check  identifier  for  suppression  of  STORAGE_ERROR  check 


STORAGE  CHECK 
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Overview 


Naming  an  exception 


Creating  an  exception  handler 


Raising  an  exception 


Handling  exceptions 


Turning  off  exception  checking 


>  Tasking  exceptions 


More  examples 


Summary 


Exception  handling  is  trickier  for  tasks 


Exceptions  during  task  communication 


Tasking  example 


B?©®pt5®m  Handling  II®  Tr5©ika®or  tor  T®®k 

•  Rules  are  not  really  different,  just  more  involved 

-  local  exceptions  handled  the  same  within  frames 

If  exception  is  raised 

•  during  elaboration  of  task  declarations 

-  the  exception  TASKING_ERROR  will  be  raised  at  the 

point  of  task  activation  (becomes  execution 
exception  in  enclosing  subprogram) 

-  the  task  will  be  marked  completed 

•  during  execution  of  task  body  (and  not  resolved  there) 

-  task  is  completed 

-  exception  is  not  propagated 

•  during  task  rendezvous 

-  this  is  the  really  tricky  part 
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Exceptions  Dystag  Task  ©omm(L3ini3©®ii5©in 


If  the  called  task  terminates  abnormally 

exception  TASKING_ERROR  is  raised  in  calling  task  at  the 
point  of  the  entry  call 


If  an  entry  call  is  made  for  entry  of  a  task  that  becomes 
completed  before  accepting  the  entry 

exception  TASKING_ERROR  is  raised  in  calling  task  at  the 
point  of  the  entry  call 


If  the  calling  task  terminates  abnormally 
no  exception  propagates  to  the  called  task 


If  an  exception  is  raised  in  called  task  within  an  accept  (and 
not  handled  there  locally) 

the  same  exception  is  raised  in  the  calling  task  at  the  point 
of  the  entry  call 

(even  if  exception  is  later  handled  outside  of  the  accept  in 
the  called  task) 
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procedure  Critical_Code  is 


Failure  :  exception; 


task  Monitor  is 

entry  Do_Something; 
end  Monitor; 
task  body  Monitor  is 

begin 

accept  Do_Something  do 
»•« 

raise  Failure; 

end  Do_Something; 

exception  --  exception  handled  here 
when  Failure  => 

T  ermination_Message ; 

end  Monitor; 


begin  -  Critical__Code 

Monitor.Do_Something; 

exception  --  same  exception  will  be  handled  here 
when  Failure  => 

Critical_Problem_Message; 


end  Critical_Code; 
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•  Summary 


Interactive  data  input 


Propagating  exception  out  of  scope  and  back 


Keeping  a  task  alive 


with  TEXT  JO;  use  TEXTJO; 

procedure  Getjnput  (Number :  out  integer)  is 

subtype  lnput_Type  is  integer  range  0..100; 
package  Intjo  is  new  INTEGERJO  (lnput_Type); 
ln_Number :  lnput_Type; 

begin  -  Getjnput 

loop  -  to  try  again  after  incorrect  input 

begin  --  inner  block  to  hold  exception  handler 

put  ("Enter  a  number  0  to  100"); 

Intjo. GET  (ln_Number); 

Number  :=  ln_Number; 

exit;  --  to  exit  loop  after  correct  input 

exception 

when  DATA_ERROR  => 

put  ("Try  again,  fat  fingers!"); 
SkipJJne;  -  must  clear  buffer 

end;  --  inner  block 

end  loop; 


end  Getjnput; 


declare 

package  Container  is 

procedure  Has_Handler; 
procedure  Raises_Exception; 
end  Container; 


procedure  Not_in_Package  is 
begin 

Container.  Raises__Exception; 
exception 

when  others  =>  raise; 
end  Not_in_Package; 


package  body  Container  is 
Crazy  :  exception; 
procedure  Has_Handler  is 
begin 

Not_in_Package; 

exception 

when  Crazy  =>  Tell_Everyone; 
end  Has_Handler; 
procedure  Raises_Exception  is 
begin 

raise  Crazy; 

end  Raises_Exception; 
end  Container; 

begin 

Container.Has_Handler; 


task  Monitor  is 

entry  Do_Something; 
end  Monitor; 

task  body  Monitor  is 
begin 

loop  -  for  never-ending  repetition 
••• 

select 

accept  Do_Something  do 

begin  --  block  for  exception  handier 

mm* 

raise  Failure; 
exception 

when  Failure  =>  Recover; 
end;  --  block 

end  Do_Something;  --  exception  must  be 

--  lowered  before  exiting 


end  select; 

end  loop; 

exception 

when  others  => 

Termination_Message; 
end  Monitor; 
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